Insertion support

app/Main.hs

@@ -1,8 +1,23 @@
 module Main where
 
-import qualified MyLib (someFunc)
+import Options.Applicative
+
+import Control.Monad.Buuka
+       (BuukaM, runBuukaM)
+
+import Data.Environment
+
+import qualified Operations
+
+commands :: Parser (BuukaM ())
+commands = subparser
+  (  command "insert" (info (insertOpts Operations.insert) (progDesc "Insert a new bookmark")))
+  where
+    insertOpts f =
+        f <$> strOption (long "url" <> short 'u' <> metavar "URL")
+          <*> optional (strOption (long "title"))
 
 main :: IO ()
 main = do
-  putStrLn "Hello, Haskell!"
+  let env = Environment "."
-  MyLib.someFunc
+  execParser (info (commands <**> helper) fullDesc) >>= runBuukaM env

buuka.cabal

@@ -35,14 +35,23 @@ library
   import:              common-stanza
   exposed-modules:     MyLib
                      , Database.Migrations
+                     , Control.Monad.Buuka
+                     , Operations.Insert
+                     , Operations
+                     , Data.Environment
+                     , Data.Buuka
   -- other-modules:
   build-depends:       aeson
                      , yaml
                      , mtl
                      , transformers
-                     , unliftio-core
+                     , unliftio
                      , conduit
                      , conduit-extra
+                     , containers
+                     , exceptions
+                     , bytestring
+                     , filepath
   hs-source-dirs:      src
 
 executable buuka

buuka.yaml

@@ -0,0 +1,11 @@
+content:
+  https://example.com:
+    url: https://example.com
+    title: foo
+  foo:
+    url: foo
+    title: null
+  bar:
+    url: bar
+    title: null
+version: 0

default.nix

@@ -1,6 +1,7 @@
-{ mkDerivation, aeson, base, conduit, conduit-extra, hedgehog
+{ mkDerivation, aeson, base, bytestring, conduit, conduit-extra
-, hedgehog-corpus, mtl, optparse-applicative, stdenv, tasty
+, containers, exceptions, filepath, hedgehog, hedgehog-corpus, mtl
-, tasty-hedgehog, text, transformers, unliftio-core, yaml
+, optparse-applicative, stdenv, tasty, tasty-hedgehog, text
+, transformers, unliftio, yaml
 }:
 mkDerivation {
   pname = "buuka";
@@ -9,8 +10,8 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    aeson base conduit conduit-extra mtl transformers unliftio-core
+    aeson base bytestring conduit conduit-extra containers exceptions
-    yaml
+    filepath mtl transformers unliftio yaml
   ];
   executableHaskellDepends = [ base optparse-applicative ];
   testHaskellDepends = [

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 }