Internal.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
-- | directory-layout internals
module System.Directory.Layout.Internal where

import           Control.Applicative
import           Control.Lens
import           Control.Monad.Free
import           Data.ByteString (ByteString)
#if __GLASGOW_HASKELL__ >= 708
import qualified Data.ByteString as ByteString
#endif
import           Data.Data (Data, Typeable)
import           Data.Foldable (Foldable)
import qualified Data.HashMap.Strict as HashMap
import           Data.Semigroup (Semigroup(..))
import           Data.String (IsString(..))
#if __GLASGOW_HASKELL__ >= 708
import           Data.Word (Word8)
#endif
import           Data.Text (Text)
#if __GLASGOW_HASKELL__ >= 708
import           GHC.Exts (IsList(..))
#endif
import           GHC.Generics (Generic)
import           System.FilePath ((</>))
import qualified System.Posix as Posix

-- $setup
-- >>> import qualified Data.ByteString as ByteString

-- | Directory layout description
newtype Layout a = L { unL :: Free F a }
  deriving (Functor, Applicative, Monad, Foldable, Traversable, Typeable, Generic)

-- | The underlying 'Functor'
data F a =
    F String (Maybe Contents) Aux a
  | SL String FilePath Bool Aux a
  | D String a Aux a
  | E
    deriving (Eq, Functor, Foldable, Traversable, Typeable, Generic)

-- | Regular file contents
data Contents =
    Binary ByteString
  | Text Text
  | CopyOf FilePath
    deriving (Eq, Typeable, Data, Generic)

instance IsString Contents where
  fromString = Text . fromString

#if __GLASGOW_HASKELL__ >= 708
instance IsList Contents where
  type Item Contents = Word8
  fromList = Binary . ByteString.pack
  toList = error "Contents.toList: not implemented"
#endif

-- | Auxiliary data
data Aux = Aux (Maybe User) (Maybe Group) (Maybe Posix.FileMode)
    deriving (Show, Eq, Typeable, Generic)

-- | File owner
data User =
    UserID Posix.UserID
  | Username String
    deriving (Show, Eq, Typeable, Generic)

instance IsString User where
  fromString = Username

-- | File group
data Group =
    GroupID Posix.GroupID
  | Groupname String
    deriving (Show, Eq, Typeable, Generic)

instance IsString Group where
  fromString = Groupname

-- | Equality check does not care about the order the files are listed insofar
-- they are consistent, i.e. different things aren't named the same
instance Eq (Layout a) where
  L xs == L ys = go "." xs == go "." ys
   where
    go root (Free t@(F n _ _ m)) =
      HashMap.singleton (root </> n) (() <$ t) <> go root m
    go root (Free t@(SL n _ _ _ m)) =
      HashMap.singleton (root </> n) (() <$ t) <> go root m
    go root (Free t@(D n is _ m)) =
      HashMap.singleton (root </> n) (() <$ t) <> go (root </> n) is <> go root m
    go _ (Free E) = HashMap.empty
    go _ (Pure _) = HashMap.empty

instance Semigroup (Layout a) where
  (<>) = (>>)

-- | Regular file with some contents or empty
--
-- >>> let layout = file "foo"
file :: String -> Layout ()
file name = L (liftF (F name anything defaux ()))

-- | Symbolic link
--
-- >>> let layout = symlink "foo" "bar"
symlink
  :: String   -- link's name
  -> FilePath -- link's source
  -> Layout ()
symlink name s = L (liftF (SL name s False defaux ()))

-- | Directory
--
-- >>> :{
-- let layout = dir "foo" $ do
--       file "bar"
--       file "baz"
-- :}
dir :: String -> Layout a -> Layout ()
dir name is = L (Free (D name (unL is >> liftF E) defaux (Pure ())))

-- | Empty directory
--
-- >>> let layout = emptydir "foo"
emptydir :: String -> Layout ()
emptydir name = dir name (return ())

-- | A nested list of directories
--
-- >>> :{
-- let layout = dirs ["foo", "bar"] $ do
--                file "qux"
--                file "quux"
-- :}
dirs :: [String] -> Layout () -> Layout ()
dirs names l = foldr dir l names

-- | The default (empty) auxiliary data
defaux :: Aux
defaux = Aux Nothing Nothing Nothing

-- | An optic into file contents
contents :: Traversal' (Layout a) (Maybe Contents)
contents f (L (Free (F n cs a x@(Pure _)))) = f cs <&> \cs' -> L (Free (F n cs' a x))
contents _ l = pure l
{-# INLINE contents #-}

-- | Binary contents
--
-- >>> let layout = file "foo" & contents ?~ binary (ByteString.pack [1..10])
binary :: ByteString -> Contents
binary = Binary

-- | Plain text contents
--
-- >>> let layout = file "foo" & contents ?~ text (Data.Text.pack "hello")
text :: Text -> Contents
text = Text

-- | Contents are the copy of whose of the real file
--
-- >>> let layout = file "foo" & contents ?~ copyOf "/home/user/.vimrc"
copyOf :: FilePath -> Contents
copyOf = CopyOf

-- | Anything
--
-- >>> let layout = file "foo" & contents .~ anything
-- >>> let layout = file "foo" & user .~ anything
anything :: Maybe a
anything = Nothing

-- | An optic into symbolic link source
--
-- >>> symlink "foo" "bar" ^? source
-- Just "bar"
source :: Traversal' (Layout a) String
source f (L (Free (SL n s e a x@(Pure _)))) = f s <&> \s' -> L (Free (SL n s' e a x))
source _ l = pure l
{-# INLINE source #-}

-- | An optic into symbolic link source expected existence
--
-- >>> let layout = symlink "foo" "bar" & exists .~ True
exists :: Traversal' (Layout a) Bool
exists f (L (Free (SL n s e a x@(Pure _)))) = f e <&> \e' -> L (Free (SL n s e' a x))
exists _ l = pure l
{-# INLINE exists #-}

-- | An optic into file auxiliary data
aux :: Traversal' (Layout a) Aux
aux f (L (Free (F n cs a x@(Pure _)))) = f a <&> \a' -> L (Free (F n cs a' x))
aux f (L (Free (SL n s e a x@(Pure _)))) = f a <&> \a' -> L (Free (SL n s e a' x))
aux f (L (Free (D n is a x@(Pure _)))) = f a <&> \a' -> L (Free (D n is a' x))
aux _ l = pure l
{-# INLINE aux #-}

-- | An optic into file owner
--
-- >>> let layout = file "foo" & user ?~ uid 0
user :: Traversal' (Layout a) (Maybe User)
user = aux . \f (Aux x y z) -> f x <&> \x' -> Aux x' y z

-- | Set the file owner by uid
uid :: Posix.UserID -> User
uid = UserID

-- | Set the file owner by username
--
-- >>> let layout = file "foo" & user ?~ username "root"
username :: String -> User
username = Username

-- | An optic into file group
--
-- >>> let layout = file "foo" & group ?~ gid 0
group :: Traversal' (Layout a) (Maybe Group)
group = aux . \f (Aux x y z) -> f y <&> \y' -> Aux x y' z

-- | Set the file group by groupname
gid :: Posix.GroupID -> Group
gid = GroupID

-- | Set the file group by groupname
--
-- >>> let layout = file "foo" & group ?~ groupname "wheel"
groupname :: String -> Group
groupname = Groupname

-- | An optic into file mode
--
-- >>> let layout = file "foo" & mode ?~ 0o100777
mode :: Traversal' (Layout a) (Maybe Posix.FileMode)
mode = aux . \f (Aux x y z) -> f z <&> \z' -> Aux x y z'

-- | An optic into directory contents
innards :: Traversal' (Layout a) (Layout a)
innards f (L (Free (D n is a x@(Pure _)))) = fmap unL (f (L is)) <&> \is' -> L (Free (D n is' a x))
innards _ l = pure l
{-# INLINE innards #-}

-- | An optic into the directory contents of the particular directory
--
-- >>> :{
-- dirs ["foo", "bar", "baz"] (symlink "qux" "quux")
--   ^? into "foo".into "bar".into "baz".focus "qux".source
-- :}
-- Just "quux"
into :: String -> Traversal' (Layout ()) (Layout ())
into s = focus s.innards

-- | An optic into the particular node
focus :: String -> Traversal' (Layout ()) (Layout ())
focus k f = fmap L . go . unL where
  go (Free (F n cs a x))
    | n == k =
      g (liftF (F n cs a ())) <&> \(Free (F _ cs' a' _)) -> Free (F n cs' a' x)
    | otherwise =
      go x <&> Free . F n cs a
  go (Free (D n is a x))
    | n == k =
      g (Free (D n is a (Pure ()))) <&> \(Free (D _ is' a' _)) -> Free (D n is' a' x)
    | otherwise =
      go x <&> Free . D n is a
  go (Free (SL n s e a x))
    | n == k =
      g (liftF (SL n s e a ())) <&> \(Free (SL _ s' e' a' _)) -> Free (SL n s' e' a' x)
    | otherwise =
      go x <&> Free . SL n s e a
  go (Free E) = pure (Free E)
  go (Pure x) = pure (Pure x)

  g = fmap unL . f . L
{-# INLINE focus #-}