{-# 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