Insertion support

This commit is contained in:
Mats Rauhala 2020-12-30 23:29:56 +02:00
parent 98341a8c9f
commit 4806e06444
10 changed files with 202 additions and 9 deletions

View File

@ -1,8 +1,23 @@
module Main where 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 :: IO ()
main = do main = do
putStrLn "Hello, Haskell!" let env = Environment "."
MyLib.someFunc execParser (info (commands <**> helper) fullDesc) >>= runBuukaM env

View File

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

11
buuka.yaml Normal file
View File

@ -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

View File

@ -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 { mkDerivation {
pname = "buuka"; pname = "buuka";
@ -9,8 +10,8 @@ mkDerivation {
isLibrary = true; isLibrary = true;
isExecutable = true; isExecutable = true;
libraryHaskellDepends = [ 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 ]; executableHaskellDepends = [ base optparse-applicative ];
testHaskellDepends = [ testHaskellDepends = [

View File

@ -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

54
src/Data/Buuka.hs Normal file
View File

@ -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)

4
src/Data/Environment.hs Normal file
View File

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

View File

@ -55,6 +55,12 @@ toVersioned x =
, content = toJSON 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 -- | Convert a json value into result type 'a' doing migrations if required
fromVersioned :: forall a. Migratable a => Versioned -> Result a fromVersioned :: forall a. Migratable a => Versioned -> Result a
fromVersioned = worker (kind @a) fromVersioned = worker (kind @a)

6
src/Operations.hs Normal file
View File

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

13
src/Operations/Insert.hs Normal file
View File

@ -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 }