module Gis.Saga.Cmd where
import Data.Map (elems)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, fromJust)
import GHC.IO.Exception
import Gis.Saga.Types
import Gis.Saga.Utils
import System.Process (system)
import System.Posix.Temp (mkdtemp)
import System.FilePath.Posix (replaceDirectory, joinPath)
import System.Directory (getTemporaryDirectory)
progName :: String
progName = "saga_cmd"
doSaga :: SagaCmd -> IO FilePath
doSaga (SagaCmd lib mod (kIn, kOut) ps maybePre maybePost fOut fIn) = do
pre fIn fOut
r <- saga lib mod (elems ps ++ [(kIn,fIn),(kOut,fOut)])
case r of
ExitSuccess -> do
post fIn fOut
return fOut
ExitFailure _ -> error "saga_cmd failed"
where
pre = fromMaybe nthn maybePre
post = fromMaybe nthn maybePost
nthn _ _ = return ()
saga ::
String
-> String
-> [(String,String)]
-> IO ExitCode
saga lib mod params =
do putStrLn cmd
system cmd
where
renderParams = map renderPara
renderPara (k,v) = "-" ++ k ++ "=" ++ v
cmd = unwords [
progName
,lib
,mod
,unwords . renderParams $ params
]
adjustSagaCmdParas :: CmdPars -> SagaCmd -> SagaCmd
adjustSagaCmdParas cmdPrs cmd@(SagaCmd{sParas = libPrs}) =
cmd {sParas = adjustParas libPrs cmdPrs}
adjustParas :: ParaMap
-> CmdPars
-> ParaMap
adjustParas libPrs cmdPrs = M.mapWithKey lkp m'
where
m = M.union cmdPrs $ M.map snd libPrs
m' = M.filterWithKey (\k _ -> k `elem` M.keys libPrs) m
lkp k v = (fst $ fromJust (M.lookup k libPrs), v)
doCmdChain :: [SagaIoCmdExt] -> CmdPars -> FilePath -> Maybe FilePath -> IO FilePath
doCmdChain chain pars fIn fOut = do
let outFsDefault = tail $ scanl appendFileName fIn (map snd chain)
outFs <- case fOut of
Nothing -> return outFsDefault
Just f -> do
dtempDir <- getTemporaryDirectory
let dtempT = joinPath [dtempDir, "sagaPipe"]
dtemp <- mkdtemp dtempT
return $ map (`replaceDirectory` dtemp) (init outFsDefault) ++ [f]
let chain' = map (\(f,ext) -> f ext) $ zip (map fst chain) outFs
foldl (\fOut f -> do
fIn' <- fOut
doSaga . adjustSagaCmdParas pars . f $ fIn'
) (return fIn) chain'
lkpChain :: SagaIoCmdDB -> [String] -> [SagaIoCmdExt]
lkpChain db = map (`lkpCmd` db)
lkpCmd :: String -> SagaIoCmdDB -> SagaIoCmdExt
lkpCmd s db = fromMaybe (error "Command is not yet implemented") $ M.lookup s db