{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Control.Funflow.External where
import Control.Funflow.ContentHashable (ContentHash, ContentHashable, ExternallyAssuredDirectory (..),
ExternallyAssuredFile (..))
import qualified Control.Funflow.ContentStore as CS
import Control.Lens.TH
import Data.Aeson (FromJSON, ToJSON)
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup
#endif
import Data.Store (Store)
import Data.String (IsString (..))
import qualified Data.Text as T
import GHC.Generics (Generic)
import Path
import System.Posix.Types (CGid, CUid)
data InputPath
= IPItem CS.Item
| IPExternalFile ExternallyAssuredFile
| IPExternalDir ExternallyAssuredDirectory
deriving (Generic, Show)
instance ContentHashable IO InputPath
instance FromJSON InputPath
instance ToJSON InputPath
instance Store InputPath
data ParamField
= ParamText !T.Text
| ParamPath !InputPath
| ParamEnv !T.Text
| ParamUid
| ParamGid
| ParamOut
| ParamCmd Param
deriving (Generic, Show)
instance ContentHashable IO ParamField
instance FromJSON ParamField
instance ToJSON ParamField
instance Store ParamField
newtype Param = Param [ParamField]
deriving (Generic, Monoid, Semigroup, Show)
instance IsString Param where
fromString s = Param [ParamText (fromString s)]
instance ContentHashable IO Param
instance FromJSON Param
instance ToJSON Param
instance Store Param
data ConvParam f = ConvParam
{ convPath :: CS.Item -> f (Path Abs Dir)
, convEnv :: T.Text -> f T.Text
, convUid :: f CUid
, convGid :: f CGid
, convOut :: f (Path Abs Dir)
}
paramFieldToText :: Applicative f
=> ConvParam f -> ParamField -> f T.Text
paramFieldToText _ (ParamText txt) = pure txt
paramFieldToText c (ParamPath (IPItem item)) = T.pack . fromAbsDir <$> convPath c item
paramFieldToText _ (ParamPath (IPExternalFile (ExternallyAssuredFile item)))
= pure . T.pack . fromAbsFile $ item
paramFieldToText _ (ParamPath (IPExternalDir (ExternallyAssuredDirectory item)))
= pure . T.pack . fromAbsDir $ item
paramFieldToText c (ParamEnv env) = convEnv c env
paramFieldToText c ParamUid = T.pack . show <$> convUid c
paramFieldToText c ParamGid = T.pack . show <$> convGid c
paramFieldToText c ParamOut = T.pack . fromAbsDir <$> convOut c
paramFieldToText c (ParamCmd cmd) = paramToText c cmd
paramToText :: Applicative f
=> ConvParam f -> Param -> f T.Text
paramToText c (Param ps) = mconcat <$> traverse (paramFieldToText c) ps
stringParam :: String -> Param
stringParam str = Param [ParamText (T.pack str)]
textParam :: T.Text -> Param
textParam txt = Param [ParamText txt]
pathParam :: InputPath -> Param
pathParam item = Param [ParamPath item]
contentParam :: CS.Content t -> Param
contentParam (CS.All item) = pathParam $ IPItem item
contentParam (item CS.:</> path) =
pathParam (IPItem item) <> stringParam (toFilePath path)
externalFileParam :: ExternallyAssuredFile -> Param
externalFileParam = pathParam . IPExternalFile
externalDirectoryParam :: ExternallyAssuredDirectory -> Param
externalDirectoryParam = pathParam . IPExternalDir
envParam :: T.Text -> Param
envParam env = Param [ParamEnv env]
uidParam :: Param
uidParam = Param [ParamUid]
gidParam :: Param
gidParam = Param [ParamGid]
outParam :: Param
outParam = Param [ParamOut]
data OutputCapture
= NoOutputCapture
| StdOutCapture
| CustomOutCapture (Path Rel File)
deriving (Generic, Show)
outputCaptureToRelFile :: OutputCapture -> Maybe (Path Rel File)
outputCaptureToRelFile NoOutputCapture = Nothing
outputCaptureToRelFile StdOutCapture = Just [relfile|out|]
outputCaptureToRelFile (CustomOutCapture file) = Just file
instance ContentHashable IO OutputCapture
instance FromJSON OutputCapture
instance ToJSON OutputCapture
instance Store OutputCapture
data Env
= EnvInherit
| EnvExplicit [(T.Text, Param)]
deriving (Generic, Show)
instance ContentHashable IO Env
instance FromJSON Env
instance ToJSON Env
instance Store Env
data ExternalTask = ExternalTask {
_etCommand :: T.Text
, _etParams :: [Param]
, _etEnv :: Env
, _etWriteToStdOut :: OutputCapture
} deriving (Generic, Show)
instance ContentHashable IO ExternalTask
instance FromJSON ExternalTask
instance ToJSON ExternalTask
instance Store ExternalTask
data TaskDescription = TaskDescription {
_tdOutput :: ContentHash
, _tdTask :: ExternalTask
} deriving (Generic, Show)
makeLenses ''ExternalTask
makeLenses ''TaskDescription