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

src/Data/Buuka.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Buuka
+  ( BuukaQ(..)
+  , BuukaU(..)
+  , BuukaEntry(..)
+  , URL(..)
+
+  , insert
+  )
+  where
+
+import Data.Map
+       (Map)
+import qualified Data.Map.Strict as M
+
+import Database.Migrations
+
+import Data.Aeson
+import GHC.Generics
+       (Generic)
+
+import Control.Monad.Reader
+import Control.Monad.State
+
+newtype URL = URL String
+  deriving stock (Show, Eq, Generic, Ord)
+  deriving newtype (ToJSON, FromJSON, FromJSONKey, ToJSONKey)
+
+data BuukaEntry
+  = BuukaEntry { url :: URL
+               , title :: Maybe String
+               }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (ToJSON, FromJSON)
+
+instance SafeJSON BuukaEntry where
+  type Version BuukaEntry = 0
+
+newtype Buuka = Buuka ( Map URL BuukaEntry )
+  deriving newtype (Semigroup, Monoid, FromJSON, ToJSON)
+
+insert :: BuukaEntry -> Buuka -> Buuka
+insert e (Buuka b) = Buuka (M.insert (url e) e b)
+
+instance SafeJSON Buuka where
+  type Version Buuka = 0
+
+newtype BuukaQ a = BuukaQ { runBuukaQ :: Reader Buuka a }
+  deriving newtype (Functor, Applicative, Monad, MonadReader Buuka)
+
+-- Last write wins
+newtype BuukaU a = BuukaU { runBuukaU :: State Buuka a }
+  deriving newtype (Functor, Applicative, Monad, MonadState Buuka)

src/Data/Environment.hs

@@ -0,0 +1,4 @@
+module Data.Environment where
+
+newtype Environment = Environment { workdir :: FilePath }
+  deriving stock (Show, Eq)

src/Database/Migrations.hs

@@ -55,6 +55,12 @@ toVersioned x =
            , content = toJSON x
            }
 
+eitherFromVersioned :: forall a. Migratable a => Versioned -> Either String a
+eitherFromVersioned x =
+  case fromVersioned x of
+       Success s -> Right s
+       Error e -> Left e
+
 -- | Convert a json value into result type 'a' doing migrations if required
 fromVersioned :: forall a. Migratable a => Versioned -> Result a
 fromVersioned = worker (kind @a)

src/Operations.hs

@@ -0,0 +1,6 @@
+module Operations
+  ( module Operations.Insert )
+  where
+
+import Operations.Insert
+       (insert)

src/Operations/Insert.hs

@@ -0,0 +1,13 @@
+module Operations.Insert where
+
+import Control.Monad.Buuka
+
+import Control.Monad.State
+       (modify)
+
+import qualified Data.Buuka as B
+
+insert :: String -> Maybe String -> BuukaM ()
+insert url title = buukaU (modify (B.insert entry))
+  where
+    entry = B.BuukaEntry{ B.url = B.URL url, B.title = title }