75 lines
2.0 KiB
Haskell
75 lines
2.0 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
module Control.Monad.Buuka where
|
|
|
|
import Data.Buuka
|
|
import Data.Environment
|
|
import Database.Migrations
|
|
|
|
import Data.Bifunctor
|
|
(first)
|
|
|
|
import qualified Data.ByteString as B
|
|
|
|
import Data.Yaml
|
|
(ParseException, decodeEither', encode)
|
|
|
|
import System.FilePath
|
|
((</>))
|
|
|
|
import Control.Monad.Catch
|
|
import Control.Monad.Reader
|
|
import Control.Monad.State
|
|
(runState)
|
|
|
|
|
|
import UnliftIO
|
|
(MonadUnliftIO(..))
|
|
import UnliftIO.Directory
|
|
(copyFile)
|
|
import UnliftIO.Temporary
|
|
(withSystemTempDirectory)
|
|
|
|
import GHC.IO.Exception
|
|
(IOErrorType(NoSuchThing), IOException(..))
|
|
|
|
newtype BuukaM a = BuukaM (ReaderT Environment IO a)
|
|
deriving newtype ( Functor
|
|
, Applicative
|
|
, Monad
|
|
, MonadReader Environment
|
|
, MonadIO
|
|
, MonadThrow
|
|
, MonadCatch
|
|
, MonadUnliftIO
|
|
)
|
|
|
|
runBuukaM :: Environment -> BuukaM a -> IO a
|
|
runBuukaM env (BuukaM f) = runReaderT f env
|
|
|
|
data DecodeException
|
|
= YamlParseException ParseException
|
|
| MigrationException String
|
|
deriving stock (Show)
|
|
deriving anyclass (Exception)
|
|
|
|
buukaQ :: BuukaQ a -> BuukaM a
|
|
buukaQ q = do
|
|
w <- asks workdir
|
|
decoded <- (decode <$> liftIO (B.readFile (w </> "buuka.yaml"))) `catch` handleNotFound
|
|
either (throwM) (pure . runReader (runBuukaQ q)) decoded
|
|
where
|
|
handleNotFound IOError{ioe_type = NoSuchThing} = pure (Right mempty)
|
|
handleNotFound e = throwM e
|
|
decode = first MigrationException . eitherFromVersioned <=< first YamlParseException . decodeEither'
|
|
|
|
buukaU :: BuukaU a -> BuukaM a
|
|
buukaU u = do
|
|
buuka <- buukaQ ask
|
|
w <- asks workdir
|
|
let (a,newBuuka) = runState (runBuukaU u) buuka
|
|
let versioned = toVersioned newBuuka
|
|
withSystemTempDirectory "buuka" $ \path -> do
|
|
liftIO $ B.writeFile (path </> "buuka.yaml") (encode versioned)
|
|
copyFile (path </> "buuka.yaml") (w </> "buuka.yaml")
|
|
pure a
|