{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedLists   #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE ViewPatterns      #-}

{-# OPTIONS_GHC -Wno-orphans #-}

-- | Implementation of the @dhall to-directory-tree@ subcommand
module Dhall.DirectoryTree
    ( -- * Filesystem
      toDirectoryTree
    , FilesystemError(..)

      -- * Low-level types and functions
    , module Dhall.DirectoryTree.Types
    , decodeDirectoryTree
    , directoryTreeType
    ) where

import Control.Applicative       (empty)
import Control.Exception         (Exception)
import Control.Monad             (unless, when)
import Data.Either.Validation    (Validation (..))
import Data.Functor.Identity     (Identity (..))
import Data.Maybe                (fromMaybe, isJust)
import Data.Sequence             (Seq)
import Data.Text                 (Text)
import Data.Void                 (Void)
import Dhall.DirectoryTree.Types
import Dhall.Marshal.Decode      (Decoder (..), Expector)
import Dhall.Src                 (Src)
import Dhall.Syntax
    ( Chunks (..)
    , Const (..)
    , Expr (..)
    , RecordField (..)
    , Var (..)
    )
import System.FilePath           ((</>))
import System.PosixCompat.Types  (FileMode, GroupID, UserID)

import qualified Control.Exception           as Exception
import qualified Data.Foldable               as Foldable
import qualified Data.Text                   as Text
import qualified Data.Text.IO                as Text.IO
import qualified Dhall.Core                  as Core
import qualified Dhall.Map                   as Map
import qualified Dhall.Marshal.Decode        as Decode
import qualified Dhall.Pretty
import qualified Dhall.TypeCheck             as TypeCheck
import qualified Dhall.Util                  as Util
import qualified Prettyprinter               as Pretty
import qualified Prettyprinter.Render.String as Pretty
import qualified System.Directory            as Directory
import qualified System.FilePath             as FilePath
#ifdef mingw32_HOST_OS
import System.IO.Error           (illegalOperationErrorType, mkIOError)
#else
import qualified System.Posix.User           as Posix
#endif
import qualified System.PosixCompat.Files    as Posix

{-| Attempt to transform a Dhall record into a directory tree where:

    * Records are translated into directories

    * @Map@s are also translated into directories

    * @Text@ values or fields are translated into files

    * @Optional@ values are omitted if @None@

    * There is a more advanced way to construct directory trees using a fixpoint
      encoding. See the documentation below on that.

    For example, the following Dhall record:

    > { dir = { `hello.txt` = "Hello\n" }
    > , `goodbye.txt`= Some "Goodbye\n"
    > , `missing.txt` = None Text
    > }

    ... should translate to this directory tree:

    > $ tree result
    > result
    > ├── dir
    > │   └── hello.txt
    > └── goodbye.txt
    >
    > $ cat result/dir/hello.txt
    > Hello
    >
    > $ cat result/goodbye.txt
    > Goodbye

    Use this in conjunction with the Prelude's support for rendering JSON/YAML
    in "pure Dhall" so that you can generate files containing JSON. For example:

    > let JSON =
    >       https://prelude.dhall-lang.org/v12.0.0/JSON/package.dhall sha256:843783d29e60b558c2de431ce1206ce34bdfde375fcf06de8ec5bf77092fdef7
    >
    > in  { `example.json` =
    >         JSON.render (JSON.array [ JSON.number 1.0, JSON.bool True ])
    >     , `example.yaml` =
    >         JSON.renderYAML
    >           (JSON.object (toMap { foo = JSON.string "Hello", bar = JSON.null }))
    >     }

    ... which would generate:

    > $ cat result/example.json
    > [ 1.0, true ]
    >
    > $ cat result/example.yaml
    > ! "bar": null
    > ! "foo": "Hello"

    /Advanced construction of directory trees/

    In addition to the ways described above using "simple" Dhall values to
    construct the directory tree there is one based on a fixpoint encoding. It
    works by passing a value of the following type to the interpreter:

    > let User = < UserId : Natural | UserName : Text >
    >
    > let Group = < GroupId : Natural | GroupName : Text >
    >
    > let Access =
    >       { execute : Optional Bool
    >       , read : Optional Bool
    >       , write : Optional Bool
    >       }
    >
    > let Mode =
    >       { user : Optional Access
    >       , group : Optional Access
    >       , other : Optional Access
    >       }
    >
    > let Entry =
    >       \(content : Type) ->
    >         { name : Text
    >         , content : content
    >         , user : Optional User
    >         , group : Optional Group
    >         , mode : Optional Mode
    >         }
    >
    > in  forall (tree : Type) ->
    >     forall  ( make
    >             : { directory : Entry (List tree) -> tree
    >               , file : Entry Text -> tree
    >               }
    >             ) ->
    >       List tree

    The fact that the metadata for filesystem entries is modeled after the POSIX
    permission model comes with the unfortunate downside that it might not apply
    to other systems: There, changes to the metadata (user, group, permissions)
    might be a no-op and __no warning will be issued__.
    This is a leaking abstraction of the
    [unix-compat](https://hackage.haskell.org/package/unix-compat) package used
    internally.

    __NOTE__: This utility does not take care of type-checking and normalizing
    the provided expression. This will raise a `FilesystemError` exception or a
    `Dhall.Marshal.Decode.DhallErrors` exception upon encountering an expression
    that cannot be converted as-is.
-}
toDirectoryTree
    :: Bool -- ^ Whether to allow path separators in file names or not
    -> FilePath
    -> Expr Void Void
    -> IO ()
toDirectoryTree :: Bool -> FilePath -> Expr Void Void -> IO ()
toDirectoryTree Bool
allowSeparators FilePath
path Expr Void Void
expression = case Expr Void Void
expression of
    RecordLit Map Text (RecordField Void Void)
keyValues ->
        forall k (f :: * -> *) a.
(Ord k, Applicative f) =>
(k -> a -> f ()) -> Map k a -> f ()
Map.unorderedTraverseWithKey_ Text -> Expr Void Void -> IO ()
process forall a b. (a -> b) -> a -> b
$ forall s a. RecordField s a -> Expr s a
recordFieldValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (RecordField Void Void)
keyValues

    ListLit (Just (Record [ (Text
"mapKey", forall s a. RecordField s a -> Expr s a
recordFieldValue -> Expr Void Void
Text), (Text
"mapValue", RecordField Void Void
_) ])) [] ->
        forall (m :: * -> *) a. Monad m => a -> m a
return ()

    ListLit Maybe (Expr Void Void)
_ Seq (Expr Void Void)
records
        | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq (Expr Void Void)
records)
        , Just [(Text, Expr Void Void)]
keyValues <- forall {m :: * -> *} {s} {a}.
(Monad m, Alternative m) =>
[Expr s a] -> m [(Text, Expr s a)]
extract (forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq (Expr Void Void)
records) ->
            forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
Foldable.traverse_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Expr Void Void -> IO ()
process) [(Text, Expr Void Void)]
keyValues

    TextLit (Chunks [] Text
text) ->
        FilePath -> Text -> IO ()
Text.IO.writeFile FilePath
path Text
text

    Some Expr Void Void
value ->
        Bool -> FilePath -> Expr Void Void -> IO ()
toDirectoryTree Bool
allowSeparators FilePath
path Expr Void Void
value

    App (Field (Union Map Text (Maybe (Expr Void Void))
_) FieldSelection Void
_) Expr Void Void
value -> do
        Bool -> FilePath -> Expr Void Void -> IO ()
toDirectoryTree Bool
allowSeparators FilePath
path Expr Void Void
value

    App Expr Void Void
None Expr Void Void
_ ->
        forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- If this pattern matches we assume the user wants to use the fixpoint
    -- approach, hence we typecheck it and output error messages like we would
    -- do for every other Dhall program.
    Lam Maybe CharacterSet
_ FunctionBinding Void Void
_ (Lam Maybe CharacterSet
_ FunctionBinding Void Void
_ Expr Void Void
_) -> do
        Seq FilesystemEntry
entries <- forall s. Expr s Void -> IO (Seq FilesystemEntry)
decodeDirectoryTree Expr Void Void
expression

        Bool -> FilePath -> Seq FilesystemEntry -> IO ()
processFilesystemEntryList Bool
allowSeparators FilePath
path Seq FilesystemEntry
entries

    Expr Void Void
_ ->
        forall {a}. IO a
die
  where
    extract :: [Expr s a] -> m [(Text, Expr s a)]
extract [] =
        forall (m :: * -> *) a. Monad m => a -> m a
return []

    extract (RecordLit [ (Text
"mapKey", forall s a. RecordField s a -> Expr s a
recordFieldValue -> TextLit (Chunks [] Text
key))
                       , (Text
"mapValue", forall s a. RecordField s a -> Expr s a
recordFieldValue -> Expr s a
value)] : [Expr s a]
records) =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text
key, Expr s a
value) forall a. a -> [a] -> [a]
:) ([Expr s a] -> m [(Text, Expr s a)]
extract [Expr s a]
records)

    extract [Expr s a]
_ =
        forall (f :: * -> *) a. Alternative f => f a
empty

    process :: Text -> Expr Void Void -> IO ()
process Text
key Expr Void Void
value = do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
allowSeparators Bool -> Bool -> Bool
&& Text -> Text -> Bool
Text.isInfixOf (FilePath -> Text
Text.pack [ Char
FilePath.pathSeparator ]) Text
key) forall a b. (a -> b) -> a -> b
$
            forall {a}. IO a
die

        Bool -> FilePath -> IO ()
Directory.createDirectoryIfMissing Bool
allowSeparators FilePath
path

        Bool -> FilePath -> Expr Void Void -> IO ()
toDirectoryTree Bool
allowSeparators (FilePath
path FilePath -> FilePath -> FilePath
</> Text -> FilePath
Text.unpack Text
key) Expr Void Void
value

    die :: IO a
die = forall e a. Exception e => e -> IO a
Exception.throwIO FilesystemError{Expr Void Void
unexpectedExpression :: Expr Void Void
unexpectedExpression :: Expr Void Void
..}
      where
        unexpectedExpression :: Expr Void Void
unexpectedExpression = Expr Void Void
expression

-- | Decode a fixpoint directory tree from a Dhall expression.
decodeDirectoryTree :: Expr s Void -> IO (Seq FilesystemEntry)
decodeDirectoryTree :: forall s. Expr s Void -> IO (Seq FilesystemEntry)
decodeDirectoryTree (forall s a. Expr s a -> Expr s a
Core.alphaNormalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a t. Expr s a -> Expr t a
Core.denote -> expression :: Expr Src Void
expression@(Lam Maybe CharacterSet
_ FunctionBinding Src Void
_ (Lam Maybe CharacterSet
_ FunctionBinding Src Void
_ Expr Src Void
body))) = do
    Expr Src Void
expected' <- case Expector (Expr Src Void)
directoryTreeType of
        Success Expr Src Void
x -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Void
x
        Failure ExpectedTypeErrors
e -> forall e a. Exception e => e -> IO a
Exception.throwIO ExpectedTypeErrors
e

    Expr Src Void
_ <- forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
Core.throws forall a b. (a -> b) -> a -> b
$ forall s. Expr s Void -> Either (TypeError s Void) (Expr s Void)
TypeCheck.typeOf forall a b. (a -> b) -> a -> b
$ forall s a. Expr s a -> Expr s a -> Expr s a
Annot Expr Src Void
expression Expr Src Void
expected'

    case forall a. Decoder a -> Expr Src Void -> Extractor Src Void a
Decode.extract Decoder (Seq FilesystemEntry)
decoder Expr Src Void
body of
        Success Seq FilesystemEntry
x -> forall (m :: * -> *) a. Monad m => a -> m a
return Seq FilesystemEntry
x
        Failure ExtractErrors Src Void
e -> forall e a. Exception e => e -> IO a
Exception.throwIO ExtractErrors Src Void
e
    where
        decoder :: Decoder (Seq FilesystemEntry)
        decoder :: Decoder (Seq FilesystemEntry)
decoder = forall a. FromDhall a => Decoder a
Decode.auto
decodeDirectoryTree Expr s Void
expr = forall e a. Exception e => e -> IO a
Exception.throwIO forall a b. (a -> b) -> a -> b
$ Expr Void Void -> FilesystemError
FilesystemError forall a b. (a -> b) -> a -> b
$ forall s a t. Expr s a -> Expr t a
Core.denote Expr s Void
expr

-- | The type of a fixpoint directory tree expression.
directoryTreeType :: Expector (Expr Src Void)
directoryTreeType :: Expector (Expr Src Void)
directoryTreeType = forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
Pi forall a. Maybe a
Nothing Text
"tree" (forall s a. Const -> Expr s a
Const Const
Type)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
Pi forall a. Maybe a
Nothing Text
"make" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expector (Expr Src Void)
makeType forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall s a. Expr s a -> Expr s a -> Expr s a
App forall s a. Expr s a
List (forall s a. Var -> Expr s a
Var (Text -> Int -> Var
V Text
"tree" Int
0))))

-- | The type of make part of a fixpoint directory tree expression.
makeType :: Expector (Expr Src Void)
makeType :: Expector (Expr Src Void)
makeType = forall s a. Map Text (RecordField s a) -> Expr s a
Record forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. Ord k => [(k, v)] -> Map k v
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
    [ forall b.
Text
-> Decoder b
-> Validation ExpectedTypeErrors (Text, RecordField Src Void)
makeConstructor Text
"directory" (forall a. FromDhall a => Decoder a
Decode.auto :: Decoder DirectoryEntry)
    , forall b.
Text
-> Decoder b
-> Validation ExpectedTypeErrors (Text, RecordField Src Void)
makeConstructor Text
"file" (forall a. FromDhall a => Decoder a
Decode.auto :: Decoder FileEntry)
    ]
    where
        makeConstructor :: Text -> Decoder b -> Expector (Text, RecordField Src Void)
        makeConstructor :: forall b.
Text
-> Decoder b
-> Validation ExpectedTypeErrors (Text, RecordField Src Void)
makeConstructor Text
name Decoder b
dec = (Text
name,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. Expr s a -> RecordField s a
Core.makeRecordField
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s a.
Maybe CharacterSet -> Text -> Expr s a -> Expr s a -> Expr s a
Pi forall a. Maybe a
Nothing Text
"_" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Decoder a -> Expector (Expr Src Void)
expected Decoder b
dec forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall s a. Var -> Expr s a
Var (Text -> Int -> Var
V Text
"tree" Int
0)))

-- | Resolve a `User` to a numerical id.
getUser :: User -> IO UserID
getUser :: User -> IO UserID
getUser (UserId UserID
uid) = forall (m :: * -> *) a. Monad m => a -> m a
return UserID
uid
getUser (UserName FilePath
name) =
#ifdef mingw32_HOST_OS
    ioError $ mkIOError illegalOperationErrorType x Nothing Nothing
    where x = "System.Posix.User.getUserEntryForName: not supported"
#else
    UserEntry -> UserID
Posix.userID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO UserEntry
Posix.getUserEntryForName FilePath
name
#endif

-- | Resolve a `Group` to a numerical id.
getGroup :: Group -> IO GroupID
getGroup :: Group -> IO GroupID
getGroup (GroupId GroupID
gid) = forall (m :: * -> *) a. Monad m => a -> m a
return GroupID
gid
getGroup (GroupName FilePath
name) = 
#ifdef mingw32_HOST_OS
    ioError $ mkIOError illegalOperationErrorType x Nothing Nothing
    where x = "System.Posix.User.getGroupEntryForName: not supported"
#else
    GroupEntry -> GroupID
Posix.groupID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO GroupEntry
Posix.getGroupEntryForName FilePath
name
#endif

-- | Process a `FilesystemEntry`. Writes the content to disk and apply the
-- metadata to the newly created item.
processFilesystemEntry :: Bool -> FilePath -> FilesystemEntry -> IO ()
processFilesystemEntry :: Bool -> FilePath -> FilesystemEntry -> IO ()
processFilesystemEntry Bool
allowSeparators FilePath
path (DirectoryEntry DirectoryEntry
entry) = do
    let path' :: FilePath
path' = FilePath
path FilePath -> FilePath -> FilePath
</> forall a. Entry a -> FilePath
entryName DirectoryEntry
entry
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Entry a -> Bool
hasMetadata DirectoryEntry
entry Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isMetadataSupported) forall a b. (a -> b) -> a -> b
$
        forall e a. Exception e => e -> IO a
Exception.throwIO forall a b. (a -> b) -> a -> b
$ FilePath -> MetadataUnsupportedError
MetadataUnsupportedError FilePath
path'
    Bool -> FilePath -> IO ()
Directory.createDirectoryIfMissing Bool
allowSeparators FilePath
path'
    Bool -> FilePath -> Seq FilesystemEntry -> IO ()
processFilesystemEntryList Bool
allowSeparators FilePath
path' forall a b. (a -> b) -> a -> b
$ forall a. Entry a -> a
entryContent DirectoryEntry
entry
    -- It is important that we write the metadata after we wrote the content of
    -- the directories/files below this directory as we might lock ourself out
    -- by changing ownership or permissions.
    forall a. Entry a -> FilePath -> IO ()
applyMetadata DirectoryEntry
entry FilePath
path'
processFilesystemEntry Bool
_ FilePath
path (FileEntry FileEntry
entry) = do
    let path' :: FilePath
path' = FilePath
path FilePath -> FilePath -> FilePath
</> forall a. Entry a -> FilePath
entryName FileEntry
entry
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Entry a -> Bool
hasMetadata FileEntry
entry Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isMetadataSupported) forall a b. (a -> b) -> a -> b
$
        forall e a. Exception e => e -> IO a
Exception.throwIO forall a b. (a -> b) -> a -> b
$ FilePath -> MetadataUnsupportedError
MetadataUnsupportedError FilePath
path'
    FilePath -> Text -> IO ()
Text.IO.writeFile FilePath
path' forall a b. (a -> b) -> a -> b
$ forall a. Entry a -> a
entryContent FileEntry
entry
    -- It is important that we write the metadata after we wrote the content of
    -- the file as we might lock ourself out by changing ownership or
    -- permissions.
    forall a. Entry a -> FilePath -> IO ()
applyMetadata FileEntry
entry FilePath
path'

-- | Process a list of `FilesystemEntry`s.
processFilesystemEntryList :: Bool -> FilePath -> Seq FilesystemEntry -> IO ()
processFilesystemEntryList :: Bool -> FilePath -> Seq FilesystemEntry -> IO ()
processFilesystemEntryList Bool
allowSeparators FilePath
path = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
Foldable.traverse_
    (Bool -> FilePath -> FilesystemEntry -> IO ()
processFilesystemEntry Bool
allowSeparators FilePath
path)

-- | Does this entry have some metadata set?
hasMetadata :: Entry a -> Bool
hasMetadata :: forall a. Entry a -> Bool
hasMetadata Entry a
entry
    =  forall a. Maybe a -> Bool
isJust (forall a. Entry a -> Maybe User
entryUser Entry a
entry)
    Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust (forall a. Entry a -> Maybe Group
entryGroup Entry a
entry)
    Bool -> Bool -> Bool
|| forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Mode Maybe -> Bool
hasMode (forall a. Entry a -> Maybe (Mode Maybe)
entryMode Entry a
entry)
    where
        hasMode :: Mode Maybe -> Bool
        hasMode :: Mode Maybe -> Bool
hasMode Mode Maybe
mode
            =  forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Access Maybe -> Bool
hasAccess (forall (f :: * -> *). Mode f -> f (Access f)
modeUser Mode Maybe
mode)
            Bool -> Bool -> Bool
|| forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Access Maybe -> Bool
hasAccess (forall (f :: * -> *). Mode f -> f (Access f)
modeGroup Mode Maybe
mode)
            Bool -> Bool -> Bool
|| forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Access Maybe -> Bool
hasAccess (forall (f :: * -> *). Mode f -> f (Access f)
modeOther Mode Maybe
mode)

        hasAccess :: Access Maybe -> Bool
        hasAccess :: Access Maybe -> Bool
hasAccess Access Maybe
access
            =  forall a. Maybe a -> Bool
isJust (forall (f :: * -> *). Access f -> f Bool
accessExecute Access Maybe
access)
            Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust (forall (f :: * -> *). Access f -> f Bool
accessRead Access Maybe
access)
            Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust (forall (f :: * -> *). Access f -> f Bool
accessWrite Access Maybe
access)

-- | Set the metadata of an object referenced by a path.
applyMetadata :: Entry a -> FilePath -> IO ()
applyMetadata :: forall a. Entry a -> FilePath -> IO ()
applyMetadata Entry a
entry FilePath
fp = do
    FileStatus
s <- FilePath -> IO FileStatus
Posix.getFileStatus FilePath
fp
    let user :: UserID
user = FileStatus -> UserID
Posix.fileOwner FileStatus
s
        group :: GroupID
group = FileStatus -> GroupID
Posix.fileGroup FileStatus
s
        mode :: Mode Identity
mode = FileMode -> Mode Identity
fileModeToMode forall a b. (a -> b) -> a -> b
$ FileStatus -> FileMode
Posix.fileMode FileStatus
s

    UserID
user' <- User -> IO UserID
getUser forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (UserID -> User
UserId UserID
user) (forall a. Entry a -> Maybe User
entryUser Entry a
entry)
    GroupID
group' <- Group -> IO GroupID
getGroup forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (GroupID -> Group
GroupId GroupID
group) (forall a. Entry a -> Maybe Group
entryGroup Entry a
entry)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((UserID
user', GroupID
group') forall a. Eq a => a -> a -> Bool
== (UserID
user, GroupID
group)) forall a b. (a -> b) -> a -> b
$
        FilePath -> UserID -> GroupID -> IO ()
Posix.setOwnerAndGroup FilePath
fp UserID
user' GroupID
group'

    let mode' :: Mode Identity
mode' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Mode Identity
mode (Mode Identity -> Mode Maybe -> Mode Identity
updateModeWith Mode Identity
mode) (forall a. Entry a -> Maybe (Mode Maybe)
entryMode Entry a
entry)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Mode Identity
mode' forall a. Eq a => a -> a -> Bool
== Mode Identity
mode) forall a b. (a -> b) -> a -> b
$
        FilePath -> FileMode -> IO ()
setFileMode FilePath
fp forall a b. (a -> b) -> a -> b
$ Mode Identity -> FileMode
modeToFileMode Mode Identity
mode'

-- | Calculate the new `Mode` from the current mode and the changes specified by
-- the user.
updateModeWith :: Mode Identity -> Mode Maybe -> Mode Identity
updateModeWith :: Mode Identity -> Mode Maybe -> Mode Identity
updateModeWith Mode Identity
x Mode Maybe
y = Mode
    { modeUser :: Identity (Access Identity)
modeUser = (Mode Identity -> Identity (Access Identity))
-> (Mode Maybe -> Maybe (Access Maybe))
-> Identity (Access Identity)
combine forall (f :: * -> *). Mode f -> f (Access f)
modeUser forall (f :: * -> *). Mode f -> f (Access f)
modeUser
    , modeGroup :: Identity (Access Identity)
modeGroup = (Mode Identity -> Identity (Access Identity))
-> (Mode Maybe -> Maybe (Access Maybe))
-> Identity (Access Identity)
combine forall (f :: * -> *). Mode f -> f (Access f)
modeGroup forall (f :: * -> *). Mode f -> f (Access f)
modeGroup
    , modeOther :: Identity (Access Identity)
modeOther = (Mode Identity -> Identity (Access Identity))
-> (Mode Maybe -> Maybe (Access Maybe))
-> Identity (Access Identity)
combine forall (f :: * -> *). Mode f -> f (Access f)
modeOther forall (f :: * -> *). Mode f -> f (Access f)
modeOther
    }
    where
        combine :: (Mode Identity -> Identity (Access Identity))
-> (Mode Maybe -> Maybe (Access Maybe))
-> Identity (Access Identity)
combine Mode Identity -> Identity (Access Identity)
f Mode Maybe -> Maybe (Access Maybe)
g = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Mode Identity -> Identity (Access Identity)
f Mode Identity
x) (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. Access Identity -> Access Maybe -> Access Identity
updateAccessWith (forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ Mode Identity -> Identity (Access Identity)
f Mode Identity
x)) (Mode Maybe -> Maybe (Access Maybe)
g Mode Maybe
y)

-- | Calculate the new `Access` from the current permissions and the changes
-- specified by the user.
updateAccessWith :: Access Identity -> Access Maybe -> Access Identity
updateAccessWith :: Access Identity -> Access Maybe -> Access Identity
updateAccessWith Access Identity
x Access Maybe
y = Access
    { accessExecute :: Identity Bool
accessExecute = forall {a}.
(Access Identity -> Identity a)
-> (Access Maybe -> Maybe a) -> Identity a
combine forall (f :: * -> *). Access f -> f Bool
accessExecute forall (f :: * -> *). Access f -> f Bool
accessExecute
    , accessRead :: Identity Bool
accessRead = forall {a}.
(Access Identity -> Identity a)
-> (Access Maybe -> Maybe a) -> Identity a
combine forall (f :: * -> *). Access f -> f Bool
accessRead forall (f :: * -> *). Access f -> f Bool
accessRead
    , accessWrite :: Identity Bool
accessWrite = forall {a}.
(Access Identity -> Identity a)
-> (Access Maybe -> Maybe a) -> Identity a
combine forall (f :: * -> *). Access f -> f Bool
accessWrite forall (f :: * -> *). Access f -> f Bool
accessWrite
    }
    where
        combine :: (Access Identity -> Identity a)
-> (Access Maybe -> Maybe a) -> Identity a
combine Access Identity -> Identity a
f Access Maybe -> Maybe a
g = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Access Identity -> Identity a
f Access Identity
x) forall a. a -> Identity a
Identity (Access Maybe -> Maybe a
g Access Maybe
y)

-- | Convert a filesystem mode given as a bitmask (`FileMode`) to an ADT
-- (`Mode`).
fileModeToMode :: FileMode -> Mode Identity
fileModeToMode :: FileMode -> Mode Identity
fileModeToMode FileMode
mode = Mode
    { modeUser :: Identity (Access Identity)
modeUser = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ Access
        { accessExecute :: Identity Bool
accessExecute = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ FileMode
mode FileMode -> FileMode -> Bool
`hasFileMode` FileMode
Posix.ownerExecuteMode
        , accessRead :: Identity Bool
accessRead = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ FileMode
mode FileMode -> FileMode -> Bool
`hasFileMode` FileMode
Posix.ownerReadMode
        , accessWrite :: Identity Bool
accessWrite = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ FileMode
mode FileMode -> FileMode -> Bool
`hasFileMode` FileMode
Posix.ownerReadMode
        }
    , modeGroup :: Identity (Access Identity)
modeGroup = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ Access
        { accessExecute :: Identity Bool
accessExecute = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ FileMode
mode FileMode -> FileMode -> Bool
`hasFileMode` FileMode
Posix.groupExecuteMode
        , accessRead :: Identity Bool
accessRead = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ FileMode
mode FileMode -> FileMode -> Bool
`hasFileMode` FileMode
Posix.groupReadMode
        , accessWrite :: Identity Bool
accessWrite = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ FileMode
mode FileMode -> FileMode -> Bool
`hasFileMode` FileMode
Posix.groupReadMode
        }
    , modeOther :: Identity (Access Identity)
modeOther = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ Access
        { accessExecute :: Identity Bool
accessExecute = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ FileMode
mode FileMode -> FileMode -> Bool
`hasFileMode` FileMode
Posix.otherExecuteMode
        , accessRead :: Identity Bool
accessRead = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ FileMode
mode FileMode -> FileMode -> Bool
`hasFileMode` FileMode
Posix.otherReadMode
        , accessWrite :: Identity Bool
accessWrite = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ FileMode
mode FileMode -> FileMode -> Bool
`hasFileMode` FileMode
Posix.otherReadMode
        }
    }

-- | Convert a filesystem mode given as an ADT (`Mode`) to a bitmask
-- (`FileMode`).
modeToFileMode :: Mode Identity -> FileMode
modeToFileMode :: Mode Identity -> FileMode
modeToFileMode Mode Identity
mode = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FileMode -> FileMode -> FileMode
Posix.unionFileModes FileMode
Posix.nullFileMode forall a b. (a -> b) -> a -> b
$
    [ FileMode
Posix.ownerExecuteMode | forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Access f -> f Bool
accessExecute (forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Mode f -> f (Access f)
modeUser  Mode Identity
mode) ] forall a. Semigroup a => a -> a -> a
<>
    [ FileMode
Posix.ownerReadMode    | forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Access f -> f Bool
accessRead    (forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Mode f -> f (Access f)
modeUser  Mode Identity
mode) ] forall a. Semigroup a => a -> a -> a
<>
    [ FileMode
Posix.ownerWriteMode   | forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Access f -> f Bool
accessWrite   (forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Mode f -> f (Access f)
modeUser  Mode Identity
mode) ] forall a. Semigroup a => a -> a -> a
<>
    [ FileMode
Posix.groupExecuteMode | forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Access f -> f Bool
accessExecute (forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Mode f -> f (Access f)
modeGroup Mode Identity
mode) ] forall a. Semigroup a => a -> a -> a
<>
    [ FileMode
Posix.groupReadMode    | forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Access f -> f Bool
accessRead    (forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Mode f -> f (Access f)
modeGroup Mode Identity
mode) ] forall a. Semigroup a => a -> a -> a
<>
    [ FileMode
Posix.groupWriteMode   | forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Access f -> f Bool
accessWrite   (forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Mode f -> f (Access f)
modeGroup Mode Identity
mode) ] forall a. Semigroup a => a -> a -> a
<>
    [ FileMode
Posix.otherExecuteMode | forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Access f -> f Bool
accessExecute (forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Mode f -> f (Access f)
modeOther Mode Identity
mode) ] forall a. Semigroup a => a -> a -> a
<>
    [ FileMode
Posix.otherReadMode    | forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Access f -> f Bool
accessRead    (forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Mode f -> f (Access f)
modeOther Mode Identity
mode) ] forall a. Semigroup a => a -> a -> a
<>
    [ FileMode
Posix.otherWriteMode   | forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Access f -> f Bool
accessWrite   (forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Mode f -> f (Access f)
modeOther Mode Identity
mode) ]

-- | Check whether the second `FileMode` is contained in the first one.
hasFileMode :: FileMode -> FileMode -> Bool
hasFileMode :: FileMode -> FileMode -> Bool
hasFileMode FileMode
mode FileMode
x = (FileMode
mode FileMode -> FileMode -> FileMode
`Posix.intersectFileModes` FileMode
x) forall a. Eq a => a -> a -> Bool
== FileMode
x

{- | This error indicates that you supplied an invalid Dhall expression to the
     `toDirectoryTree` function.  The Dhall expression could not be translated
     to a directory tree.
-}
newtype FilesystemError =
    FilesystemError { FilesystemError -> Expr Void Void
unexpectedExpression :: Expr Void Void }

instance Exception FilesystemError

instance Show FilesystemError where
    show :: FilesystemError -> FilePath
show FilesystemError{Expr Void Void
unexpectedExpression :: Expr Void Void
unexpectedExpression :: FilesystemError -> Expr Void Void
..} =
        forall ann. SimpleDocStream ann -> FilePath
Pretty.renderString (forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout Doc Ann
message)
      where
        message :: Doc Ann
message =
          forall string. IsString string => string
Util._ERROR forall a. Semigroup a => a -> a -> a
<> ": Not a valid directory tree expression                             \n\\
          \                                                                                   \n\\
          \Explanation: Only a subset of Dhall expressions can be converted to a directory    \n\\
          \tree.  Specifically, record literals or maps can be converted to directories,      \n\\
          \❰Text❱ literals can be converted to files, and ❰Optional❱ values are included if   \n\\
          \❰Some❱ and omitted if ❰None❱.  Values of union types can also be converted if      \n\\
          \they are an alternative which has a non-nullary constructor whose argument is of   \n\\
          \an otherwise convertible type.  Furthermore, there is a more advanced approach to  \n\\
          \constructing a directory tree utilizing a fixpoint encoding. Consult the upstream  \n\\
          \documentation of the `toDirectoryTree` function in the Dhall.Directory module for  \n\\
          \further information on that.                                                       \n\\
          \No other type of value can be translated to a directory tree.                      \n\\
          \                                                                                   \n\\
          \For example, this is a valid expression that can be translated to a directory      \n\\
          \tree:                                                                              \n\\
          \                                                                                   \n\\
          \                                                                                   \n\\
          \    ┌──────────────────────────────────┐                                           \n\\
          \    │ { `example.json` = \"[1, true]\" } │                                         \n\\
          \    └──────────────────────────────────┘                                           \n\\
          \                                                                                   \n\\
          \                                                                                   \n\\
          \In contrast, the following expression is not allowed due to containing a           \n\\
          \❰Natural❱ field, which cannot be translated in this way:                           \n\\
          \                                                                                   \n\\
          \                                                                                   \n\\
          \    ┌───────────────────────┐                                                      \n\\
          \    │ { `example.txt` = 1 } │                                                      \n\\
          \    └───────────────────────┘                                                      \n\\
          \                                                                                   \n\\
          \                                                                                   \n\\
          \Note that key names cannot contain path separators:                                \n\\
          \                                                                                   \n\\
          \                                                                                   \n\\
          \    ┌─────────────────────────────────────┐                                        \n\\
          \    │ { `directory/example.txt` = \"ABC\" } │ Invalid: Key contains a forward slash\n\\
          \    └─────────────────────────────────────┘                                        \n\\
          \                                                                                   \n\\
          \                                                                                   \n\\
          \Instead, you need to refactor the expression to use nested records instead:        \n\\
          \                                                                                   \n\\
          \                                                                                   \n\\
          \    ┌───────────────────────────────────────────┐                                  \n\\
          \    │ { directory = { `example.txt` = \"ABC\" } } │                                \n\\
          \    └───────────────────────────────────────────┘                                  \n\\
          \                                                                                   \n\\
          \                                                                                   \n\\
          \You tried to translate the following expression to a directory tree:               \n\\
          \                                                                                   \n\\
          \" <> Util.insert unexpectedExpression <> "\n\\
          \                                                                                   \n\\
          \... which is not an expression that can be translated to a directory tree.         \n"

{- | This error indicates that you want to set some metadata for a file or
     directory, but that operation is not supported  on your platform.
-}
newtype MetadataUnsupportedError =
    MetadataUnsupportedError { MetadataUnsupportedError -> FilePath
metadataForPath :: FilePath }

instance Exception MetadataUnsupportedError

instance Show MetadataUnsupportedError where
    show :: MetadataUnsupportedError -> FilePath
show MetadataUnsupportedError{FilePath
metadataForPath :: FilePath
metadataForPath :: MetadataUnsupportedError -> FilePath
..} =
        forall ann. SimpleDocStream ann -> FilePath
Pretty.renderString (forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout forall {ann}. Doc ann
message)
      where
        message :: Doc ann
message =
          forall string. IsString string => string
Util._ERROR forall a. Semigroup a => a -> a -> a
<> ": Setting metadata is not supported on this platform.               \n\\
          \                                                                                   \n\\
          \Explanation: Your Dhall expression indicates that you intend to set some metadata  \n\\
          \like ownership or permissions for the following file or directory:                 \n\\
          \                                                                                   \n\\
          \" <> Pretty.pretty metadataForPath <> "\n\\
          \                                                                                   \n\\
          \... which is not supported on your platform.                                       \n"