diff --git a/app/Main.hs b/app/Main.hs index 60d904e..9edd49a 100644 --- a/app/Main.hs +++ b/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!" - MyLib.someFunc + let env = Environment "." + execParser (info (commands <**> helper) fullDesc) >>= runBuukaM env diff --git a/buuka.cabal b/buuka.cabal index 75392a0..09c0cb3 100644 --- a/buuka.cabal +++ b/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 diff --git a/buuka.yaml b/buuka.yaml new file mode 100644 index 0000000..bed7f5c --- /dev/null +++ b/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 diff --git a/default.nix b/default.nix index b000bc7..0b34698 100644 --- a/default.nix +++ b/default.nix @@ -1,6 +1,7 @@ -{ mkDerivation, aeson, base, conduit, conduit-extra, hedgehog -, hedgehog-corpus, mtl, optparse-applicative, stdenv, tasty -, tasty-hedgehog, text, transformers, unliftio-core, yaml +{ mkDerivation, aeson, base, bytestring, conduit, conduit-extra +, containers, exceptions, filepath, hedgehog, hedgehog-corpus, mtl +, 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 - yaml + aeson base bytestring conduit conduit-extra containers exceptions + filepath mtl transformers unliftio yaml ]; executableHaskellDepends = [ base optparse-applicative ]; testHaskellDepends = [ diff --git a/src/Control/Monad/Buuka.hs b/src/Control/Monad/Buuka.hs new file mode 100644 index 0000000..075e859 --- /dev/null +++ b/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 diff --git a/src/Data/Buuka.hs b/src/Data/Buuka.hs new file mode 100644 index 0000000..dc69d64 --- /dev/null +++ b/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) diff --git a/src/Data/Environment.hs b/src/Data/Environment.hs new file mode 100644 index 0000000..e41b1c9 --- /dev/null +++ b/src/Data/Environment.hs @@ -0,0 +1,4 @@ +module Data.Environment where + +newtype Environment = Environment { workdir :: FilePath } + deriving stock (Show, Eq) diff --git a/src/Database/Migrations.hs b/src/Database/Migrations.hs index ea8ff20..c8a226b 100644 --- a/src/Database/Migrations.hs +++ b/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) diff --git a/src/Operations.hs b/src/Operations.hs new file mode 100644 index 0000000..cfb2af6 --- /dev/null +++ b/src/Operations.hs @@ -0,0 +1,6 @@ +module Operations + ( module Operations.Insert ) + where + +import Operations.Insert + (insert) diff --git a/src/Operations/Insert.hs b/src/Operations/Insert.hs new file mode 100644 index 0000000..4f840d2 --- /dev/null +++ b/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 }