kit-0.6.6: Kit/Commands.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Kit.Commands (
  Command,
  liftKit,
  mySpec,
  mySpecFile,
  myRepository,
  runCommand,
  defaultLocalRepoPath,
  defaultLocalRepository
) where

import Kit.Util
import Kit.Spec
import Kit.Repository

import qualified Data.ByteString as BS
import System.Exit (exitFailure)

import Control.Monad.Error
import Control.Monad.Reader

newtype Command a = Command (ReaderT (KitSpec, KitRepository) (ErrorT String IO) a) deriving Monad

instance MonadIO Command where
  liftIO a = Command $ liftIO a

liftKit :: KitIO a -> Command a
liftKit = Command . ReaderT . const

mySpec :: Command KitSpec
mySpec = Command $ fmap fst ask

myRepository :: Command KitRepository
myRepository = Command $ fmap snd ask

mySpecFile :: Command FilePath
mySpecFile = return "KitSpec"

runCommand :: Command a -> IO ()
runCommand (Command cmd) = run $ do
  spec <- readSpec "KitSpec"
  repository <- liftIO defaultLocalRepository
  runReaderT cmd (spec, repository)
  where run = (handleFails =<<) . runErrorT
        handleFails = either (\msg -> putStrLn ("kit error: " ++ msg) >> exitFailure) (const $ return ())

defaultLocalRepoPath :: IO FilePath
defaultLocalRepoPath = (</> ".kit" </> "repository") <$> getHomeDirectory 

defaultLocalRepository :: IO KitRepository
defaultLocalRepository = KitRepository <$> defaultLocalRepoPath

readSpec :: FilePath -> KitIO KitSpec
readSpec path = checkExists path >>= liftIO . BS.readFile >>= ErrorT . return . parses
  where checkExists pathToSpec = do
          doesExist <- liftIO $ doesFileExist pathToSpec 
          if doesExist then return pathToSpec else throwError $ "Couldn't find the spec at " ++ pathToSpec 
        parses = maybeToRight "Parse error in KitSpec file" . decodeSpec