{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.Runtime.Files
  ( readYaml,
    rewrite_,
    statusM,
    aesonYAMLOptions,
    select,
    remove,
    addHash,
    forbidOverride,
    cleanRelativePath,
  )
where

import Control.Exception (catch, throwIO, tryJust)
import Control.Monad.Error.Class (MonadError (..))
import Data.Aeson
  ( FromJSON (..),
    Object,
    Options (..),
    ToJSON (..),
    Value (..),
    defaultOptions,
  )
import Data.ByteString (readFile, writeFile)
import Data.Char (isUpper, toLower)
import Data.List (elemIndex, stripPrefix)
import Data.Map (lookup)
import Data.Text (toTitle)
import qualified Data.Text.Encoding as T
import Data.Yaml (decodeThrow)
import Data.Yaml.Pretty (defConfig, encodePretty, setConfCompare, setConfDropNull)
import HWM.Core.Formatting
import HWM.Core.Result (Issue)
import Relude hiding (readFile, writeFile)
import System.Directory (doesFileExist, removeFile)
import System.FilePath (joinPath, splitDirectories)
import System.IO.Error (isDoesNotExistError)

printException :: SomeException -> String
printException :: SomeException -> String
printException = SomeException -> String
forall b a. (Show a, IsString b) => a -> b
show

safeIO :: IO a -> IO (Either String a)
safeIO :: forall a. IO a -> IO (Either String a)
safeIO = (SomeException -> Maybe String) -> IO a -> IO (Either String a)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (SomeException -> String) -> SomeException -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
printException)

remove :: (MonadIO m) => FilePath -> m ()
remove :: forall (m :: * -> *). MonadIO m => String -> m ()
remove String
file = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
file IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\IOError
e -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IOError -> Bool
isDoesNotExistError IOError
e) (IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
e))

safeRead :: (MonadIO m) => FilePath -> m (Either String ByteString)
safeRead :: forall (m :: * -> *).
MonadIO m =>
String -> m (Either String ByteString)
safeRead = IO (Either String ByteString) -> m (Either String ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String ByteString) -> m (Either String ByteString))
-> (String -> IO (Either String ByteString))
-> String
-> m (Either String ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ByteString -> IO (Either String ByteString)
forall a. IO a -> IO (Either String a)
safeIO (IO ByteString -> IO (Either String ByteString))
-> (String -> IO ByteString)
-> String
-> IO (Either String ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
readFile

safeWrite :: (MonadIO m) => FilePath -> ByteString -> m (Either String ())
safeWrite :: forall (m :: * -> *).
MonadIO m =>
String -> ByteString -> m (Either String ())
safeWrite String
file ByteString
content = IO (Either String ()) -> m (Either String ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String ()) -> m (Either String ()))
-> IO (Either String ()) -> m (Either String ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either String ())
forall a. IO a -> IO (Either String a)
safeIO (String -> ByteString -> IO ()
writeFile String
file ByteString
content)

serializeYaml :: (ToJSON a) => a -> ByteString
serializeYaml :: forall a. ToJSON a => a -> ByteString
serializeYaml =
  Config -> a -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
encodePretty
    (Config -> a -> ByteString) -> Config -> a -> ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> Config -> Config
setConfDropNull Bool
True
    (Config -> Config) -> Config -> Config
forall a b. (a -> b) -> a -> b
$ (Text -> Text -> Ordering) -> Config -> Config
setConfCompare Text -> Text -> Ordering
compareFields Config
defConfig

data Yaml t = Yaml
  { forall t. Yaml t -> t
getData :: t,
    forall t. Yaml t -> Object
rawValue :: Object
  }
  deriving ((forall x. Yaml t -> Rep (Yaml t) x)
-> (forall x. Rep (Yaml t) x -> Yaml t) -> Generic (Yaml t)
forall x. Rep (Yaml t) x -> Yaml t
forall x. Yaml t -> Rep (Yaml t) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall t x. Rep (Yaml t) x -> Yaml t
forall t x. Yaml t -> Rep (Yaml t) x
$cfrom :: forall t x. Yaml t -> Rep (Yaml t) x
from :: forall x. Yaml t -> Rep (Yaml t) x
$cto :: forall t x. Rep (Yaml t) x -> Yaml t
to :: forall x. Rep (Yaml t) x -> Yaml t
Generic)

instance (FromJSON t) => FromJSON (Yaml t) where
  parseJSON :: Value -> Parser (Yaml t)
parseJSON Value
v = t -> Object -> Yaml t
forall t. t -> Object -> Yaml t
Yaml (t -> Object -> Yaml t) -> Parser t -> Parser (Object -> Yaml t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser t
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v Parser (Object -> Yaml t) -> Parser Object -> Parser (Yaml t)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser Object
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

instance (ToJSON t) => ToJSON (Yaml t) where
  toJSON :: Yaml t -> Value
toJSON (Yaml t
t Object
v) = Object -> Value
Object (Value -> Object
toObject (t -> Value
forall a. ToJSON a => a -> Value
toJSON t
t) Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> Object
v)

toObject :: Value -> Object
toObject :: Value -> Object
toObject (Object Object
x) = Object
x
toObject Value
_ = Object
forall a. Monoid a => a
mempty

mapYaml :: (Functor m) => (Maybe t -> m t) -> Maybe (Yaml t) -> m (Yaml t)
mapYaml :: forall (m :: * -> *) t.
Functor m =>
(Maybe t -> m t) -> Maybe (Yaml t) -> m (Yaml t)
mapYaml Maybe t -> m t
f (Just (Yaml t
v Object
props)) = (t -> Object -> Yaml t
forall t. t -> Object -> Yaml t
`Yaml` Object
props) (t -> Yaml t) -> m t -> m (Yaml t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe t -> m t
f (t -> Maybe t
forall a. a -> Maybe a
Just t
v)
mapYaml Maybe t -> m t
f Maybe (Yaml t)
Nothing = (t -> Object -> Yaml t
forall t. t -> Object -> Yaml t
`Yaml` Object
forall a. Monoid a => a
mempty) (t -> Yaml t) -> m t -> m (Yaml t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe t -> m t
f Maybe t
forall a. Maybe a
Nothing

fromEither :: (MonadError Issue m, FromJSON b, MonadIO m) => Either a ByteString -> m (Maybe b)
fromEither :: forall (m :: * -> *) b a.
(MonadError Issue m, FromJSON b, MonadIO m) =>
Either a ByteString -> m (Maybe b)
fromEither = (a -> m (Maybe b))
-> (ByteString -> m (Maybe b))
-> Either a ByteString
-> m (Maybe b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m (Maybe b) -> a -> m (Maybe b)
forall a b. a -> b -> a
const (m (Maybe b) -> a -> m (Maybe b))
-> m (Maybe b) -> a -> m (Maybe b)
forall a b. (a -> b) -> a -> b
$ Maybe b -> m (Maybe b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe b
forall a. Maybe a
Nothing) ((b -> Maybe b) -> m b -> m (Maybe b)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Maybe b
forall a. a -> Maybe a
Just (m b -> m (Maybe b))
-> (ByteString -> m b) -> ByteString -> m (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO b -> m b
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> (ByteString -> IO b) -> ByteString -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO b
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
decodeThrow)

withThrow :: (MonadError Issue m) => m (Either String a) -> m a
withThrow :: forall (m :: * -> *) a.
MonadError Issue m =>
m (Either String a) -> m a
withThrow m (Either String a)
x = m (Either String a)
x m (Either String a) -> (Either String a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> m a) -> (a -> m a) -> Either String a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Issue -> m a
forall a. Issue -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Issue -> m a) -> (String -> Issue) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Issue
forall a. IsString a => String -> a
fromString) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

rewrite_ :: (MonadError Issue m, MonadIO m, FromJSON t, ToJSON t) => FilePath -> (Maybe t -> m t) -> m ()
rewrite_ :: forall (m :: * -> *) t.
(MonadError Issue m, MonadIO m, FromJSON t, ToJSON t) =>
String -> (Maybe t -> m t) -> m ()
rewrite_ String
pkg Maybe t -> m t
f = do
  Either String ByteString
original <- String -> m (Either String ByteString)
forall (m :: * -> *).
MonadIO m =>
String -> m (Either String ByteString)
safeRead String
pkg
  Yaml t
yaml <- Either String ByteString -> m (Maybe (Yaml t))
forall (m :: * -> *) b a.
(MonadError Issue m, FromJSON b, MonadIO m) =>
Either a ByteString -> m (Maybe b)
fromEither Either String ByteString
original m (Maybe (Yaml t)) -> (Maybe (Yaml t) -> m (Yaml t)) -> m (Yaml t)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe t -> m t) -> Maybe (Yaml t) -> m (Yaml t)
forall (m :: * -> *) t.
Functor m =>
(Maybe t -> m t) -> Maybe (Yaml t) -> m (Yaml t)
mapYaml Maybe t -> m t
f
  m (Either String ()) -> m ()
forall (m :: * -> *) a.
MonadError Issue m =>
m (Either String a) -> m a
withThrow (String -> ByteString -> m (Either String ())
forall (m :: * -> *).
MonadIO m =>
String -> ByteString -> m (Either String ())
safeWrite String
pkg (Yaml t -> ByteString
forall a. ToJSON a => a -> ByteString
serializeYaml Yaml t
yaml))

statusM :: (MonadIO m) => FilePath -> m t -> m Status
statusM :: forall (m :: * -> *) t. MonadIO m => String -> m t -> m Status
statusM String
pkg m t
m = do
  Either String ByteString
before <- String -> m (Either String ByteString)
forall (m :: * -> *).
MonadIO m =>
String -> m (Either String ByteString)
safeRead String
pkg
  t
_ <- m t
m
  Either String ByteString
after <- String -> m (Either String ByteString)
forall (m :: * -> *).
MonadIO m =>
String -> m (Either String ByteString)
safeRead String
pkg
  Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (if Either String ByteString
before Either String ByteString -> Either String ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Either String ByteString
after then Status
Checked else Status
Updated)

readYaml :: (MonadError Issue m, MonadIO m, FromJSON a) => FilePath -> m a
readYaml :: forall (m :: * -> *) a.
(MonadError Issue m, MonadIO m, FromJSON a) =>
String -> m a
readYaml = m (Either String ByteString) -> m ByteString
forall (m :: * -> *) a.
MonadError Issue m =>
m (Either String a) -> m a
withThrow (m (Either String ByteString) -> m ByteString)
-> (String -> m (Either String ByteString))
-> String
-> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m (Either String ByteString)
forall (m :: * -> *).
MonadIO m =>
String -> m (Either String ByteString)
safeRead (String -> m ByteString) -> (ByteString -> m a) -> String -> m a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (ByteString -> IO a) -> ByteString -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO a
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
decodeThrow)

fields :: [Text]
fields :: [Text]
fields =
  (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map
    Text -> Text
toTitle
    [ Text
"name",
      Text
"version",
      Text
"github",
      Text
"license",
      Text
"author",
      Text
"category",
      Text
"synopsis",
      Text
"maintainer",
      Text
"homepage",
      Text
"copyright",
      Text
"license-file",
      Text
"description",
      Text
"bounds",
      Text
"ghc",
      Text
"resolver",
      Text
"packages",
      Text
"workspace",
      Text
"builds",
      Text
"extra-source-files",
      Text
"data-files",
      Text
"main",
      Text
"source-dirs",
      Text
"ghc-options",
      Text
"dependencies",
      Text
"library",
      Text
"executables",
      Text
"include",
      Text
"exclude",
      Text
"allow-newer",
      Text
"save-hackage-creds",
      Text
"extra-deps",
      Text
"stackYaml",
      Text
"components",
      Text
"path",
      Text
"component"
    ]

toPriority :: Text -> Int
toPriority :: Text -> Int
toPriority = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
fields) (Maybe Int -> Int) -> (Text -> Maybe Int) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [Text] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [Text]
fields)

mapTuple :: (a -> b) -> (b -> b -> c) -> a -> a -> c
mapTuple :: forall a b c. (a -> b) -> (b -> b -> c) -> a -> a -> c
mapTuple a -> b
f b -> b -> c
g a
a a
b = b -> b -> c
g (a -> b
f a
a) (a -> b
f a
b)

compareFields :: Text -> Text -> Ordering
compareFields :: Text -> Text -> Ordering
compareFields = (Text -> Text)
-> (Text -> Text -> Ordering) -> Text -> Text -> Ordering
forall a b c. (a -> b) -> (b -> b -> c) -> a -> a -> c
mapTuple Text -> Text
toTitle ((Text -> Int)
-> (Int -> Int -> Ordering) -> Text -> Text -> Ordering
forall a b c. (a -> b) -> (b -> b -> c) -> a -> a -> c
mapTuple Text -> Int
toPriority Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Text -> Text -> Ordering)
-> (Text -> Text -> Ordering) -> Text -> Text -> Ordering
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare)

toKebabCase :: String -> String
toKebabCase :: String -> String
toKebabCase = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
toKebab
  where
    toKebab :: Char -> String
toKebab Char
x
      | Char -> Bool
isUpper Char
x = [Char
'-', Char -> Char
toLower Char
x]
      | Bool
otherwise = [Char
x]

aesonYAMLOptions :: Options
aesonYAMLOptions :: Options
aesonYAMLOptions = Options
defaultOptions {fieldLabelModifier = toKebabCase, omitNothingFields = True}

select :: (MonadError Issue m, Format t, Ord t) => Text -> t -> Map t a -> m a
select :: forall (m :: * -> *) t a.
(MonadError Issue m, Format t, Ord t) =>
Text -> t -> Map t a -> m a
select Text
e t
k = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Issue -> m a
forall a. Issue -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Issue -> m a) -> Issue -> m a
forall a b. (a -> b) -> a -> b
$ String -> Issue
forall a. IsString a => String -> a
fromString (String -> Issue) -> String -> Issue
forall a b. (a -> b) -> a -> b
$ String
"Unknown " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
e String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString (t -> Text
forall a. Format a => a -> Text
format t
k) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"!") a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m a) -> (Map t a -> Maybe a) -> Map t a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Map t a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
lookup t
k

addHash :: (MonadIO m) => FilePath -> Text -> m ()
addHash :: forall (m :: * -> *). MonadIO m => String -> Text -> m ()
addHash String
filePath Text
hash = do
  Text
content <- IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
forall (m :: * -> *). MonadIO m => String -> m ByteString
readFileBS String
filePath
  let contentWithHash :: Text
contentWithHash = Text
"# hash: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hash Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
content
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => String -> ByteString -> m ()
writeFileBS String
filePath (Text -> ByteString
T.encodeUtf8 Text
contentWithHash)

forbidOverride :: (MonadIO m, MonadError e m, IsString e) => FilePath -> m ()
forbidOverride :: forall (m :: * -> *) e.
(MonadIO m, MonadError e m, IsString e) =>
String -> m ()
forbidOverride String
path = do
  Bool
exists <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
path
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ e -> m ()
forall a. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m ()) -> e -> m ()
forall a b. (a -> b) -> a -> b
$ String -> e
forall a. IsString a => String -> a
fromString (String -> e) -> String -> e
forall a b. (a -> b) -> a -> b
$ String
"File \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" already exists!"

cleanRelativePath :: Maybe String -> Maybe String
cleanRelativePath :: Maybe String -> Maybe String
cleanRelativePath Maybe String
Nothing = Maybe String
forall a. Maybe a
Nothing
cleanRelativePath (Just String
"") = Maybe String
forall a. Maybe a
Nothing
cleanRelativePath (Just String
"./") = Maybe String
forall a. Maybe a
Nothing
cleanRelativePath (Just String
".") = Maybe String
forall a. Maybe a
Nothing
cleanRelativePath (Just String
name) =
  String -> Maybe String
forall a. a -> Maybe a
Just
    (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
joinPath
    ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitDirectories
    (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
name (String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"./" String
name)