Insertion support

src/Control/Monad/Buuka.hs

@@ -0,0 +1,74 @@
+{-# 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