From 1bf856ea09b4c73933b10ac8049bdf6fb6e87bb9 Mon Sep 17 00:00:00 2001 From: "Yann Esposito (Yogsototh)" Date: Wed, 26 Dec 2018 18:31:55 +0100 Subject: [PATCH] refacto of code Type level black magic! better naming Even darker type level programming black magic Fix the updatefields Updated to usage typeclasses structure update the Comments file Added a working function ignore .db files It's happening! Using the Handler pattern Added search, need to think about non generic queries Fixes, but unsatisfactory about search Working system Fixed tests Fixed search to make it safer Cleaner test Added Show instances (will help for debug) working code add auto-test.sh script Use ixset-typed for more typesafety Working system with a "hole" in the abstraction --- .dir-locals.el | 6 + .gitignore | 1 + aggreact.cabal | 29 +- auto-test.sh | 5 + package.yaml | 17 +- repl.sh | 2 + src-exe/Main.hs | 9 +- src-test/Database/Store/Backend/SQLiteTest.hs | 111 +++++ src-test/Main.hs | 17 +- src/Aggreact.hs | 215 +++++++-- src/Aggreact/Comments.hs | 420 +++++++++--------- src/Aggreact/Css.hs | 15 + src/Aggreact/Homepage.hs | 34 +- src/Aggreact/Html.hs | 60 +++ src/Aggreact/User.hs | 33 ++ src/Database/Store.hs | 117 +++++ src/Database/Store/Backend/SQLite.hs | 322 ++++++++++++++ src/Database/Store/CRUD.hs | 62 +++ src/Database/Store/Search.hs | 26 ++ src/DevelMain.hs | 9 +- src/Generics/SOP/Fieldnames.hs | 58 +++ src/Servant/Clay.hs | 16 + stack.yaml | 7 +- 23 files changed, 1294 insertions(+), 297 deletions(-) create mode 100644 .dir-locals.el create mode 100755 auto-test.sh create mode 100755 repl.sh create mode 100644 src-test/Database/Store/Backend/SQLiteTest.hs create mode 100644 src/Aggreact/Html.hs create mode 100644 src/Aggreact/User.hs create mode 100644 src/Database/Store.hs create mode 100644 src/Database/Store/Backend/SQLite.hs create mode 100644 src/Database/Store/CRUD.hs create mode 100644 src/Database/Store/Search.hs create mode 100644 src/Generics/SOP/Fieldnames.hs diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..1be1e08 --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,6 @@ +;;; Directory Local Variables +;;; For more information see (info "(emacs) Directory Variables") + +((haskell-mode + (intero-targets "aggreact:lib" "aggreact:test:aggreact-test"))) + diff --git a/.gitignore b/.gitignore index 5edf853..14b9507 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,4 @@ /.stack-work/ state/ dist-newstyle/ +*.db \ No newline at end of file diff --git a/aggreact.cabal b/aggreact.cabal index 18343fd..ebccc28 100644 --- a/aggreact.cabal +++ b/aggreact.cabal @@ -2,7 +2,7 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 60fed7e68e1912e16f4c7e8cbf3baa477d6f37f6fb2c1e9c9f8493ca56bcb746 +-- hash: 9783f1aaf5e0695e9390f197cf2cbabe82e032dc7319e7e43ba82db01a24dded name: aggreact version: 0.1.0.0 @@ -31,13 +31,20 @@ library Aggreact.Comments Aggreact.Css Aggreact.Homepage + Aggreact.Html + Aggreact.User + Database.Store + Database.Store.Backend.SQLite + Database.Store.CRUD + Database.Store.Search DevelMain + Generics.SOP.Fieldnames Servant.Clay other-modules: Paths_aggreact hs-source-dirs: src - default-extensions: OverloadedStrings NoImplicitPrelude ScopedTypeVariables TupleSections OverloadedLists ExplicitForAll RecordWildCards GeneralizedNewtypeDeriving DeriveGeneric DerivingStrategies StandaloneDeriving + default-extensions: OverloadedStrings NoImplicitPrelude ScopedTypeVariables TupleSections OverloadedLists ExplicitForAll RecordWildCards GeneralizedNewtypeDeriving DeriveGeneric DerivingStrategies StandaloneDeriving NamedWildCards PartialTypeSignatures BlockArguments NumericUnderscores ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -Werror -O2 build-depends: acid-state @@ -50,15 +57,19 @@ library , clay , containers , foreign-store + , generics-sop , http-api-data , http-media , human-readable-duration - , ixset + , ixset-typed , protolude , safecopy , servant + , servant-auth + , servant-auth-server , servant-blaze , servant-server + , sqlite-simple , text , time , uuid @@ -72,7 +83,7 @@ executable aggreact Paths_aggreact hs-source-dirs: src-exe - default-extensions: OverloadedStrings NoImplicitPrelude ScopedTypeVariables TupleSections OverloadedLists ExplicitForAll RecordWildCards GeneralizedNewtypeDeriving DeriveGeneric DerivingStrategies StandaloneDeriving + default-extensions: OverloadedStrings NoImplicitPrelude ScopedTypeVariables TupleSections OverloadedLists ExplicitForAll RecordWildCards GeneralizedNewtypeDeriving DeriveGeneric DerivingStrategies StandaloneDeriving NamedWildCards PartialTypeSignatures BlockArguments NumericUnderscores ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -Werror -O2 -optP-Wno-nonportable-include-path -threaded -rtsopts "-with-rtsopts=-N -I0" build-depends: aggreact @@ -87,7 +98,7 @@ test-suite aggreact-doctest Paths_aggreact hs-source-dirs: src-doctest - default-extensions: OverloadedStrings NoImplicitPrelude ScopedTypeVariables TupleSections OverloadedLists ExplicitForAll RecordWildCards GeneralizedNewtypeDeriving DeriveGeneric DerivingStrategies StandaloneDeriving + default-extensions: OverloadedStrings NoImplicitPrelude ScopedTypeVariables TupleSections OverloadedLists ExplicitForAll RecordWildCards GeneralizedNewtypeDeriving DeriveGeneric DerivingStrategies StandaloneDeriving NamedWildCards PartialTypeSignatures BlockArguments NumericUnderscores ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -Werror -O2 -threaded -rtsopts -with-rtsopts=-N build-depends: Glob >=0.7 @@ -102,15 +113,19 @@ test-suite aggreact-test type: exitcode-stdio-1.0 main-is: Main.hs other-modules: + Database.Store.Backend.SQLiteTest Paths_aggreact hs-source-dirs: src-test - default-extensions: OverloadedStrings NoImplicitPrelude ScopedTypeVariables TupleSections OverloadedLists ExplicitForAll RecordWildCards GeneralizedNewtypeDeriving DeriveGeneric DerivingStrategies StandaloneDeriving + default-extensions: OverloadedStrings NoImplicitPrelude ScopedTypeVariables TupleSections OverloadedLists ExplicitForAll RecordWildCards GeneralizedNewtypeDeriving DeriveGeneric DerivingStrategies StandaloneDeriving NamedWildCards PartialTypeSignatures BlockArguments NumericUnderscores ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -Werror -O2 -threaded -rtsopts -with-rtsopts=-N build-depends: aggreact , base >=4.8 && <5 + , directory + , generics-sop , protolude + , sqlite-simple , tasty >=0.11 , tasty-hunit >=0.9 , tasty-smallcheck >=0.8 @@ -123,7 +138,7 @@ benchmark aggreact-benchmark Paths_aggreact hs-source-dirs: src-benchmark - default-extensions: OverloadedStrings NoImplicitPrelude ScopedTypeVariables TupleSections OverloadedLists ExplicitForAll RecordWildCards GeneralizedNewtypeDeriving DeriveGeneric DerivingStrategies StandaloneDeriving + default-extensions: OverloadedStrings NoImplicitPrelude ScopedTypeVariables TupleSections OverloadedLists ExplicitForAll RecordWildCards GeneralizedNewtypeDeriving DeriveGeneric DerivingStrategies StandaloneDeriving NamedWildCards PartialTypeSignatures BlockArguments NumericUnderscores ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -Werror -O2 -threaded -rtsopts -with-rtsopts=-N build-depends: aggreact diff --git a/auto-test.sh b/auto-test.sh new file mode 100755 index 0000000..23fa3ed --- /dev/null +++ b/auto-test.sh @@ -0,0 +1,5 @@ +#!/bin/bash +target="aggreact:test:aggreact-test" +ghcid \ + --command "stack ghci $target --ghci-options=-fobject-code" \ + --test "main" diff --git a/package.yaml b/package.yaml index a651018..d40de20 100644 --- a/package.yaml +++ b/package.yaml @@ -22,10 +22,10 @@ default-extensions: - DerivingStrategies # remove warn about deriving strategies - StandaloneDeriving # write deriving instance ... # need GHC > 8.6 - # - NamedWildcard # can use _type instead of just _ - # - PartialTypeSignature - # - BlockArguments # blabla do ... instead of blabla $ do ... - # - NumericUnderscores # write 1_000 instead of 1000 + - NamedWildCards # can use _type instead of just _ + - PartialTypeSignatures + - BlockArguments # blabla do ... instead of blabla $ do ... + - NumericUnderscores # write 1_000 instead of 1000 ghc-options: - -Wall - -Wcompat @@ -52,11 +52,15 @@ library: - http-api-data - http-media - human-readable-duration - - ixset + - ixset-typed + - generics-sop - safecopy - servant + - servant-auth + - servant-auth-server - servant-blaze - servant-server + - sqlite-simple - text - time - uuid @@ -98,6 +102,9 @@ tests: - tasty-hunit >=0.9 - tasty-smallcheck >=0.8 - aggreact + - generics-sop + - sqlite-simple + - directory benchmarks: aggreact-benchmark: main: Main.hs diff --git a/repl.sh b/repl.sh new file mode 100755 index 0000000..77c12d8 --- /dev/null +++ b/repl.sh @@ -0,0 +1,2 @@ +#!/bin/bash +stack ghci --ghci-options "-interactive-print=Text.Pretty.Simple.pPrint" --package pretty-simple diff --git a/src-exe/Main.hs b/src-exe/Main.hs index ee66975..9c973f2 100644 --- a/src-exe/Main.hs +++ b/src-exe/Main.hs @@ -1,9 +1,10 @@ import Protolude -import Aggreact (mainServe,Conf(..)) -import Aggreact.Comments (initDB,DBConf(..)) +import Aggreact (mainServe,Conf(..),initialize) +import Database.Store.Backend.SQLite (DBConf (SQLiteConf)) main :: IO () main = do - db <- initDB (DBConf "state") - mainServe db (Conf 3000 db) + let conf = Conf 3000 (SQLiteConf "aggreact.db" "comments") + (ch,_) <- initialize (commentConf conf) + mainServe ch conf diff --git a/src-test/Database/Store/Backend/SQLiteTest.hs b/src-test/Database/Store/Backend/SQLiteTest.hs new file mode 100644 index 0000000..3f88862 --- /dev/null +++ b/src-test/Database/Store/Backend/SQLiteTest.hs @@ -0,0 +1,111 @@ +module Database.Store.Backend.SQLiteTest where + +import Database.Store.Backend.SQLite +import Protolude +import Test.Tasty +import Test.Tasty.HUnit + +import Database.SQLite.Simple (NamedParam((:=))) +import Database.SQLite.Simple.FromRow (FromRow (..)) +import Database.SQLite.Simple.ToRow (ToRow (..)) +import Database.Store (DefaultMetas (..), Entity (..), + Id (..), Store (..)) +import qualified Database.Store.CRUD as CRUD +import qualified Database.Store.Search as Search +import Generics.SOP +import System.Directory + + +data NewFoo = NewFoo { name :: Text, age :: Int } deriving (Protolude.Generic,Eq,Ord) +instance Generics.SOP.Generic NewFoo +instance Generics.SOP.HasDatatypeInfo NewFoo +instance SQLiteSchemas NewFoo +instance FromRow NewFoo where fromRow = genericFromRow +instance ToRow NewFoo where toRow = genericToRow + +type Foo = Entity DefaultMetas NewFoo + +testSQLiteGenerics :: [TestTree] +testSQLiteGenerics = [ testCase "sqlSchemaTxt" sqlSchemaTxtTest + , testCase "updateFieldTest" updateFieldsTest + ] + +sqlSchemaTxtTest :: Assertion +sqlSchemaTxtTest = sqlSchemaTxt (Proxy :: Proxy NewFoo) @?= "name TEXT,age INT" + +sqlSchemaTxtEntityTest :: Assertion +sqlSchemaTxtEntityTest = sqlSchemaTxt (Proxy :: Proxy Foo) @?= "name TEXT,age INT" + +updateFieldsTest :: Assertion +updateFieldsTest = + let pfoo = Proxy :: Proxy NewFoo + in updateFields pfoo @?= "name := :name,age := :age" + +updateFieldsEntityTest :: Assertion +updateFieldsEntityTest = + let pfoo = Proxy :: Proxy Foo + in updateFields pfoo @?= "name := :name,age := :age" + +testSQLiteCRUD :: [TestTree] +testSQLiteCRUD = [ testCaseSteps "create" sqlCRUD ] + +saferm :: FilePath -> IO () +saferm fic = do + fileExists <- doesFileExist fic + when fileExists $ removeFile fic + +withTestDB :: (Text -> IO a) -> IO a +withTestDB actions = do + let tmpdbfile = ".test.db" + saferm tmpdbfile + res <- actions (toS tmpdbfile) + saferm tmpdbfile + return res + +sqlCRUD :: IsString t => (t -> IO a) -> IO () +sqlCRUD step = withTestDB $ \tmpfile -> do + void $ step "Initalizing" + store <- initDBFoos (SQLiteConf tmpfile "foo") + void $ step "Get something" + res1 <- readFoo store (Id "0000-0000-0000-000000000000-000000000000") + case res1 of + Just _ -> assertFailure "The DB Should be empty!" + Nothing -> return () + void $ step "Create something" + let newFoo1 = NewFoo { name = "Yann", age = 42 } + foo1 <- createFoo store newFoo1 + void $ step "Get created entity" + foo2 <- readFoo store (id foo1) + when (Just foo1 /= foo2) $ assertFailure "Foo1 and Foo2 should be equal" + void $ step "Search created entity by name" + Paginated foos _ _ <- searchFoos store (Filter {params = ["name" := ("Yann" :: Text)]}) + when (length foos /= 1) $ assertFailure "Bad numbers of found elements" + when (head foos /= Just foo1) $ assertFailure "Search returned the bad result" + void $ step "cleaning up temporary files" + +type FooSQLiteStore = SQLiteStore IO DefaultMetas NewFoo +type DBStore = StartedStore FooSQLiteStore +type FooConf = DBConf FooSQLiteStore +type FooSearchQuery = Search.SearchQuery FooSQLiteStore +type FooSearchResult = Search.SearchResult FooSQLiteStore + +initDBFoos :: FooConf -> IO DBStore +initDBFoos = init + +stopDBFoos :: DBStore -> IO () +stopDBFoos = stop + +createFoo :: DBStore -> NewFoo -> IO Foo +createFoo = CRUD.create + +readFoo :: DBStore -> Id -> IO (Maybe Foo) +readFoo = CRUD.read + +updateFoo :: DBStore -> Id -> NewFoo -> IO (Maybe Foo) +updateFoo = CRUD.update + +deleteFoo :: DBStore -> Id -> IO Bool +deleteFoo = CRUD.delete + +searchFoos :: DBStore -> FooSearchQuery -> IO FooSearchResult +searchFoos = Search.search diff --git a/src-test/Main.hs b/src-test/Main.hs index 34e768b..6e74dc5 100644 --- a/src-test/Main.hs +++ b/src-test/Main.hs @@ -1,20 +1,27 @@ import Protolude import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.SmallCheck +-- import Test.Tasty.HUnit +-- import Test.Tasty.SmallCheck -import Lib (inc) +import Database.Store.Backend.SQLiteTest main :: IO () main = defaultMain $ testGroup "all-tests" tests +tests :: [TestTree] +tests = + [ testGroup "SQLite Store" testSQLiteGenerics + , testGroup "SQLite CRUD Store" testSQLiteCRUD + ] + +{- + tests :: [TestTree] tests = [ testGroup "SmallCheck" scTests , testGroup "Unit tests" huTests ] - scTests :: [TestTree] scTests = [ testProperty "inc == succ" prop_succ @@ -38,3 +45,5 @@ case_inc_below = inc 41 @?= (42 :: Int) case_dec_above :: Assertion case_dec_above = negate (inc (negate 43)) @?= (42 :: Int) + +-} diff --git a/src/Aggreact.hs b/src/Aggreact.hs index 140e8ef..b51baae 100644 --- a/src/Aggreact.hs +++ b/src/Aggreact.hs @@ -1,8 +1,22 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- Common +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {- | Module : Aggreact @@ -23,24 +37,136 @@ module Aggreact , Conf (..) , initialize , shutdownApp + , mainWithCookies + , mainWithJWT ) where import Protolude -import Aggreact.Homepage import Aggreact.Comments -import Aggreact.Css (genCss) +import Aggreact.Css (genCss) +import Aggreact.Homepage -import Clay (Css) -import qualified Data.Acid as Acid -import Data.Time (getCurrentTime) -import qualified Data.UUID as UUID -import Network.Wai (Application) -import qualified Network.Wai.Handler.Warp as Warp +import Clay (Css) +import Data.Aeson +import qualified Data.IxSet.Typed as IxSet +import Data.Time (getCurrentTime) +import qualified Data.UUID as UUID +import Database.SQLite.Simple (NamedParam(..)) +import Database.Store (Id (..)) +import Database.Store.Backend.SQLite (Paginated(..) + , SearchQuery(..) + , SearchResult(..)) +import Network.Wai (Application) +import qualified Network.Wai.Handler.Warp as Warp import Servant import Servant.Clay import Servant.HTML.Blaze +-- Auth +import qualified Data.Text as Text +import Network.Wai.Handler.Warp (run) +import Servant.Auth.Server + +data Conf = Conf { port :: Int + , commentConf :: CommentConf } + +-- Auth + +data User = User + { name :: Text + , email :: Text } + deriving (Eq,Show,Read,Generic) + +instance ToJSON User +instance ToJWT User +instance FromJSON User +instance FromJWT User + +data Login = Login + { username :: Text + , password :: Text + } deriving (Eq, Show, Read, Generic) + +instance ToJSON Login +instance FromJSON Login + +type Protected + = "name" :> Get '[JSON] Text + :<|> "email" :> Get '[JSON] Text + +protected :: Servant.Auth.Server.AuthResult User -> Server Protected +protected _ = throwAll err401 + +type Unprotected = + "login" + :> ReqBody '[JSON] Login + :> PostNoContent '[JSON] (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie] + NoContent) + :<|> Raw + +unprotected :: CookieSettings -> JWTSettings -> Server Unprotected +unprotected cs jwts = checkCreds cs jwts + :<|> serveDirectoryFileServer "example/static" + +type API auths = (Servant.Auth.Server.Auth auths User :> Protected) + :<|> Unprotected + +server :: CookieSettings -> JWTSettings -> Server (API auths) +server cs jwts = protected :<|> unprotected cs jwts + +mainWithJWT :: IO () +mainWithJWT = do + myKey <- generateKey + let jwtCfg = defaultJWTSettings myKey + cfg = defaultCookieSettings :. jwtCfg :. EmptyContext + api = Proxy :: Proxy (API '[JWT]) + _ <- forkIO $ run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg) + putText "Started server on localhost:7249" + putText "Enter name and email separated by a space for a new token" + forever $ do + xs <- Text.words <$> getLine + case xs of + [name', email'] -> do + etoken <- makeJWT (User name' email') jwtCfg Nothing + case etoken of + Left e -> putText $ "Error generating token:\t" <> show e + Right v -> putText $ "New token:\t" <> show v + _ -> putText "Expecting a name and email separated by spaces" + +mainWithCookies :: IO () +mainWithCookies = do + -- We *also* need a key to sign the cookies + myKey <- generateKey + -- Adding some configurations. 'Cookie' requires, in addition to + -- CookieSettings, JWTSettings (for signing), so everything is just as before + let jwtCfg = defaultJWTSettings myKey + cfg = defaultCookieSettings :. jwtCfg :. EmptyContext + --- Here is the actual change + api = Proxy :: Proxy (API '[Cookie]) + run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg) + +-- Here is the login handler +checkCreds :: CookieSettings + -> JWTSettings + -> Login + -> Handler (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie] + NoContent) +checkCreds cookieSettings jwtSettings (Login "Ali Baba" "Open Sesame") = do + -- Usually you would ask a database for the user info. This is just a + -- regular servant handler, so you can follow your normal database access + -- patterns (including using 'enter'). + let usr = User "Ali Baba" "ali@email.com" + mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings usr + case mApplyCookies of + Nothing -> throwError err401 + Just applyCookies -> return $ applyCookies NoContent +checkCreds _ _ _ = throwError err401 + +-- / Auth + type CommentAPI = Get '[HTML] Homepage :<|> "comments" :> Capture "slug" Text :> Get '[HTML,JSON] CommentsPage :<|> "slugs" :> Get '[JSON] [Slug] @@ -48,52 +174,47 @@ type CommentAPI = Get '[HTML] Homepage :<|> "comments" :> ReqBody '[JSON, FormUrlEncoded] NewComment :> Post '[JSON] Comment :<|> "comment" :> Capture "commentId" Text :> Get '[HTML,JSON] CommentPage -data Conf = Conf { port :: Int - , dbcomments :: DB Comments } +handlers :: CommentHandler -> Server CommentAPI +handlers h = + Homepage <$> liftIO (getSlugs h) + :<|> showComments h + :<|> liftIO (getSlugs h) + :<|> return genCss + :<|> liftIO . createComment h + :<|> showComment h -showComments :: DB Comments -> Text -> Handler CommentsPage -showComments db s = do - cs <- liftIO . getCommentsBySlug db . Slug $ s +showComments :: CommentHandler -> Text -> Handler CommentsPage +showComments CommentHandler{..} s = do + (SR (Paginated cs _ _)) <- liftIO $ + searchComments Filter {params = ["slug" := Slug s]} now <- liftIO getCurrentTime - return CommentsPage { url = s, viewTime = now, comments = cs } + liftIO $ print cs + return CommentsPage { url = s, viewTime = now, comments = IxSet.fromList cs } -showComment :: DB Comments -> Text -> Handler CommentPage -showComment db i = +showComment :: CommentHandler -> Text -> Handler CommentPage +showComment CommentHandler{..} i = case UUID.fromText i of Nothing -> throwError err404 Just uuid -> do - cs <- liftIO . getCommentById db . Id $ uuid + cs <- liftIO . readComment . Id $ uuid now <- liftIO getCurrentTime case cs of Just c -> return CommentPage { commentPageUrl = i, commentPageViewTime = now, commentPageComment = c } _ -> throwError err404 -listSlugs :: DB Comments -> Handler [Slug] -listSlugs = liftIO . slugs +commentAPI :: Proxy CommentAPI +commentAPI = Proxy -api :: Proxy CommentAPI -api = Proxy +app :: CommentHandler -> Application +app db = serve commentAPI (handlers db) -server :: DB Comments -> Server CommentAPI -server db = - Homepage <$> listSlugs db - :<|> showComments db - :<|> listSlugs db - :<|> return genCss - :<|> liftIO . createNewComment db - :<|> showComment db +initialize :: CommentConf -> IO (CommentHandler,Application) +initialize conf = do + commentHandler <- newCommentHandler conf + return (commentHandler,app commentHandler) -app :: DB Comments -> Application -app db = serve api (server db) +shutdownApp :: CommentHandler -> IO () +shutdownApp CommentHandler{..} = stopDBComments -initialize :: IO (Conf, Application) -initialize = do - db <- initDB (DBConf "state") - return (Conf 3000 db, app db) - -shutdownApp :: Conf -> IO () -shutdownApp conf = - Acid.closeAcidState (dbcomments conf) - -mainServe :: DB Comments -> Conf -> IO () -mainServe db conf = Warp.run (port conf) (app db) +mainServe :: CommentHandler -> Conf -> IO () +mainServe ch conf = Warp.run (port conf) (app ch) diff --git a/src/Aggreact/Comments.hs b/src/Aggreact/Comments.hs index 24935d3..9d11cc1 100644 --- a/src/Aggreact/Comments.hs +++ b/src/Aggreact/Comments.hs @@ -1,19 +1,31 @@ -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} -- write "foo" and it will be the correct text type +{-# LANGUAGE NoImplicitPrelude #-} -- to use protolude for example +{-# LANGUAGE ScopedTypeVariables #-} -- write expr :: Type inside an expression +{-# LANGUAGE TupleSections #-} -- (a,,) instead of \x y -> (a,x,y) +{-# LANGUAGE OverloadedLists #-} -- write [1,2,3] :: Set +{-# LANGUAGE ExplicitForAll #-} -- f :: forall a b. a -> b -> b +{-# LANGUAGE RecordWildCards #-} -- f Conf{..} = field1 ... +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- newtype Id = Id Text deriving (StringConv Id String) +{-# LANGUAGE DeriveGeneric #-} -- deriving ToJSON ... +{-# LANGUAGE DerivingStrategies #-} -- remove warn about deriving strategies +{-# LANGUAGE StandaloneDeriving #-} -- write deriving instance ... +{-# LANGUAGE NamedWildCards #-} -- can use _type instead of just _ +{-# LANGUAGE PartialTypeSignatures #-} -- +{-# LANGUAGE BlockArguments #-} -- blabla do ... instead of blabla $ do ... +{-# LANGUAGE NumericUnderscores #-} -- write 1_000 instead of 1000 {- | Module : Aggreact.Comments Description : Example of a library file. @@ -29,8 +41,7 @@ Main datastructures module Aggreact.Comments ( -- * Types - Id (..) - , Comment (..) + Comment , CommentPage (..) , CommentsPage (..) , NewComment (..) @@ -38,67 +49,70 @@ module Aggreact.Comments , Slug (..) , ParentId (..) , UserId (..) - , DB - , DBConf (..) - -- * Operations - , initDB - , createNewComment - , slugs - , getCommentsBySlug - , getCommentsByParentId - , getCommentById + -- * Usage for DB + , CommentConf + , newCommentHandler + , CommentHandler(..) -- * HTML - , boilerplate ) where -import Protolude hiding (get, put) +import Protolude hiding (get, put) -import qualified Control.Exception as Ex -import Data.Acid (AcidState, Query, Update, - makeAcidic) -import qualified Data.Acid as Acid -import Data.Aeson (FromJSON (..), Options (..), - ToJSON (..), defaultOptions, - genericParseJSON, genericToJSON) -import Data.Char (isAlphaNum) -import Data.Data (Data (..)) -import Data.Duration (humanReadableDuration) -import qualified Data.IxSet as IxSet -import Data.SafeCopy (base, deriveSafeCopy) -import Data.Serialize (Serialize (..)) -import Data.Serialize.Text () -import Data.String (IsString (..)) -import qualified Data.Text as Text -import Data.Time (UTCTime, diffUTCTime, - getCurrentTime) -import Data.Time.Clock.Serialize () -import Data.Time.Format () -import Data.Typeable (Typeable) -import Data.UUID (UUID) -import qualified Data.UUID as UUID -import qualified Data.UUID.V4 as UUIDV4 -import qualified Text.Blaze.Html5 as H -import Text.Blaze.Html5 ((!)) -import qualified Text.Blaze.Html5.Attributes as A -import qualified Web.FormUrlEncoded as Form -import qualified Web.HttpApiData as FormI +import Aggreact.Html (boilerplate) + +import qualified Control.Exception as Ex +import Data.Aeson (FromJSON (..), ToJSON (..), + defaultOptions, + genericParseJSON, + genericToJSON) +import Data.Char (isAlphaNum) +import Data.Data (Data (..)) +import Data.Duration (humanReadableDuration) +import qualified Data.IxSet.Typed as IxSet +import Data.String (IsString (..)) +import qualified Data.Text as Text +import Data.Time (UTCTime, diffUTCTime) +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +import Database.SQLite.Simple.FromRow (FromRow(..),field) +import Database.SQLite.Simple.ToRow (ToRow(..)) +import Database.SQLite.Simple (SQLData(..),query_) + +import Data.Time.Clock.Serialize () +import Data.Time.Format () +import Data.Typeable (Typeable) +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import Database.Store (Id(..), DefaultMetas (..), Entity (..), Store(..)) +import Database.Store.Backend.SQLite as SQL +import qualified Database.Store.CRUD as CRUD +import qualified Database.Store.Search as Search +import qualified Generics.SOP as SOP +import Text.Blaze.Html5 ((!)) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import qualified Web.FormUrlEncoded as Form +import qualified Web.HttpApiData as FormI + +{- * Structure + +Each entity should have the following properties: + +* provide a type that represent the internal structure @Struct@ +* provide a type that represent the metas structure @Metas@ +* @Entity Metas Struct@ should be an instance of some Backend Store typeclass +* @Entity Metas Struct@ should be an instance of 'ToJSON' +* @Metas@ should be an instance of 'FromJSON', 'FromForm' and mainly one for all + content-type you like + +-} -- * Comments -type Comments = IxSet.IxSet Comment - --- Orphan Instance for Serialize IxSet -instance ( Serialize a - , Ord a - , IxSet.Indexable a - , Typeable a) => Serialize (IxSet.IxSet a) where - put i = put (IxSet.toList i) - get = fmap IxSet.fromList get - instance ( Ord a , ToJSON a - , IxSet.Indexable a - , Typeable a) => ToJSON (IxSet.IxSet a) where + , IxSet.Indexable ixs a + , Typeable a) => ToJSON (IxSet.IxSet ixs a) where toJSON i = toJSON (IxSet.toList i) -- * Comment @@ -106,64 +120,61 @@ instance ( Ord a data DecodeUUIDException = DecodeUUIDException deriving (Show) instance Ex.Exception DecodeUUIDException -unsecureFromJust :: Maybe a -> a -unsecureFromJust (Just x) = x -unsecureFromJust _ = Ex.throw DecodeUUIDException - -instance Serialize UUID where - put = put . UUID.toText - get = unsecureFromJust . UUID.fromText <$> get - -instance StringConv UUID [Char] where strConv l = strConv l . UUID.toString -instance StringConv UUID Text where strConv l = strConv l . UUID.toText - -newtype Id = Id UUID deriving (Eq,Ord,Generic,Data) -instance StringConv Id [Char] where strConv l (Id uuid) = strConv l uuid -instance StringConv Id Text where strConv l (Id uuid) = strConv l uuid -deriving anyclass instance FromJSON Id -deriving anyclass instance ToJSON Id -deriving anyclass instance Serialize Id - -newtype ParentId = ParentId (Maybe UUID) deriving (Eq,Ord,Generic,Data) +newtype ParentId = ParentId (Maybe UUID) deriving (Eq,Ord,Show,Generic,Data) deriving anyclass instance FromJSON ParentId deriving anyclass instance ToJSON ParentId -deriving anyclass instance Serialize ParentId +instance ToField UUID where + toField = SQLText . UUID.toText +deriving newtype instance ToField ParentId +deriving newtype instance FromField ParentId +instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (ParentId ': rest) where + toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest) -newtype Slug = Slug Text deriving (Eq,Ord,Generic,Data) +newtype Slug = Slug Text deriving (Eq,Ord,Show,Generic,Data) instance StringConv Slug [Char] where strConv l (Slug sl) = strConv l sl instance StringConv Slug Text where strConv l (Slug sl) = strConv l sl deriving anyclass instance FromJSON Slug deriving anyclass instance ToJSON Slug -deriving anyclass instance Serialize Slug +deriving newtype instance ToField Slug +deriving newtype instance FromField Slug +instance FromRow Slug where fromRow = Slug <$> field +instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Slug ': rest) where + toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest) -newtype UserId = UserId Text deriving (Eq,Ord,Generic,Data) +newtype UserId = UserId Text deriving (Eq,Ord,Show,Generic,Data) instance StringConv UserId [Char] where strConv l (UserId sl) = strConv l sl instance StringConv UserId Text where strConv l (UserId sl) = strConv l sl deriving anyclass instance FromJSON UserId deriving anyclass instance ToJSON UserId -deriving anyclass instance Serialize UserId +deriving newtype instance FromField UserId +deriving newtype instance ToField UserId +instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (UserId ': rest) where + toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest) -newtype Content = Content Text deriving (Eq,Ord,Generic,Data) +newtype Content = Content Text deriving (Eq,Ord,Show,Generic,Data) instance StringConv Content [Char] where strConv l (Content sl) = strConv l sl instance StringConv Content Text where strConv l (Content sl) = strConv l sl deriving anyclass instance FromJSON Content deriving anyclass instance ToJSON Content -deriving anyclass instance Serialize Content +deriving newtype instance FromField Content +deriving newtype instance ToField Content +instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Content ': rest) where + toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest) -newtype Term = Term Text deriving (Eq,Ord,Generic) +newtype Term = Term Text deriving (Eq,Ord,Generic) data NewComment = NewComment - { ncparent :: Maybe ParentId - , ncslug :: Slug - , nccontent :: Content - , ncuserid :: UserId - } deriving (Generic,Typeable,Eq,Ord) + { parent :: ParentId + , slug :: Slug + , content :: Content + , userid :: UserId + } deriving (Generic,Typeable,Data,Eq,Ord,Show) instance FromJSON NewComment where - parseJSON = genericParseJSON (defaultOptions { fieldLabelModifier = drop 2}) + parseJSON = genericParseJSON defaultOptions instance ToJSON NewComment where - toJSON = genericToJSON (defaultOptions { fieldLabelModifier = drop 2}) + toJSON = genericToJSON defaultOptions instance FormI.FromHttpApiData ParentId where parseUrlPiece s = do @@ -177,126 +188,38 @@ instance FormI.FromHttpApiData Slug where parseUrlPiece = fmap Slug . FormI.p instance FormI.FromHttpApiData Content where parseUrlPiece = fmap Content . FormI.parseUrlPiece instance FormI.FromHttpApiData UserId where parseUrlPiece = fmap UserId . FormI.parseUrlPiece instance Form.FromForm NewComment where - fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = drop 2} + fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity} -data Comment = - Comment - { id :: Id - , parent :: ParentId - , slug :: Slug - , created :: UTCTime - , content :: Content - , userid :: UserId - } deriving (Generic,Typeable,Eq,Ord) -deriving instance FromJSON Comment -deriving instance ToJSON Comment -deriving instance Serialize Comment -deriving instance Data Comment -instance IxSet.Indexable Comment where - empty = - IxSet.ixSet - [ IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy Id) - , IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy ParentId) - , IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy Slug) - , IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy UserId) - , IxSet.ixFun getTerms -- Ability to search content text - ] + +type NewCommentIxs = '[ParentId,Slug,Content,UserId,Term] +instance IxSet.Indexable NewCommentIxs Comment where + indices = IxSet.ixList + (IxSet.ixGen (Proxy :: Proxy ParentId)) + (IxSet.ixGen (Proxy :: Proxy Slug)) + (IxSet.ixGen (Proxy :: Proxy Content)) + (IxSet.ixGen (Proxy :: Proxy UserId)) + (IxSet.ixFun getTerms) + +type Comment = Entity DefaultMetas NewComment +type CommentIxs = '[Id,ParentId,Slug,Content,UserId,Term] +instance IxSet.Indexable CommentIxs Comment where + indices = IxSet.ixList + (IxSet.ixGen (Proxy :: Proxy Id)) + (IxSet.ixGen (Proxy :: Proxy ParentId)) + (IxSet.ixGen (Proxy :: Proxy Slug)) + (IxSet.ixGen (Proxy :: Proxy Content)) + (IxSet.ixGen (Proxy :: Proxy UserId)) + (IxSet.ixFun getTerms) + +type Comments = IxSet.IxSet CommentIxs Comment getTerms :: Comment -> [Term] -getTerms = fmap Term . Text.split (not . isAlphaNum) . unContent . content +getTerms = fmap Term . Text.split (not . isAlphaNum) . unContent . content . val where unContent (Content x) = x -$(deriveSafeCopy 0 'base ''UUID) -$(deriveSafeCopy 0 'base ''Id) -$(deriveSafeCopy 0 'base ''ParentId) -$(deriveSafeCopy 0 'base ''Slug) -$(deriveSafeCopy 0 'base ''Content) -$(deriveSafeCopy 0 'base ''UserId) -$(deriveSafeCopy 0 'base ''Comment) - -initialComments :: Comments -initialComments = IxSet.empty - -createComment :: Comment -> Update Comments () -createComment = modify . IxSet.insert - -updateComment :: Comment -> Update Comments () -updateComment comment = modify (IxSet.updateIx (id comment) comment) - -getSlugs :: Query Comments [Slug] -getSlugs = fmap fst . IxSet.groupBy <$> ask - -commentById :: Id -> Query Comments (Maybe Comment) -commentById cid = do - comments <- ask - return (IxSet.getOne (comments IxSet.@= cid)) - -commentsByParentId :: ParentId -> Query Comments Comments -commentsByParentId pid = do - comments <- ask - return (comments IxSet.@= pid) - -commentsBySlug :: Slug -> Query Comments Comments -commentsBySlug rid = do - comments <- ask - return (comments IxSet.@= rid) - -$(makeAcidic ''Comments [ 'createComment - , 'updateComment - , 'commentById - , 'commentsByParentId - , 'commentsBySlug - , 'getSlugs - ]) - -- * Operations -type DB a = AcidState a - -createNewComment :: DB Comments -> NewComment -> IO Comment -createNewComment db (NewComment pid s txt uid) = do - newId <- fmap Id UUIDV4.nextRandom - now <- getCurrentTime - let newComment = Comment newId (fromMaybe (ParentId Nothing) pid) s now txt uid - Acid.update db (UpdateComment newComment) - return newComment - -slugs :: DB Comments -> IO [Slug] -slugs db = Acid.query db GetSlugs - -getCommentById :: DB Comments -> Id -> IO (Maybe Comment) -getCommentById db i = Acid.query db (CommentById i) - -getCommentsBySlug :: DB Comments -> Slug -> IO Comments -getCommentsBySlug db s = Acid.query db (CommentsBySlug s) - -getCommentsByParentId :: DB Comments -> ParentId -> IO Comments -getCommentsByParentId db s = Acid.query db (CommentsByParentId s) - -container :: H.Html -> H.Html -container = H.div ! A.class_ "container" - -boilerplate :: H.Markup -> H.Html -boilerplate innerHtml = - H.html $ do - H.head $ do - H.title (H.text "Aggreact") - H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/main.css" - H.body $ do - H.header . container $ H.a ! A.href "/" $ H.h1 "Aggreact" - container innerHtml - H.footer . container $ do - H.code "Aggreact" - H.text " " - H.span $ do - H.text "done " - H.text " in " - H.a ! A.href "https://haskell.org" $ "Haskell" - H.text " by " - H.a ! A.href "http://yannesposito.com" $ "ye" - - data CommentPage = CommentPage { commentPageUrl :: Text @@ -306,7 +229,6 @@ data CommentPage = instance ToJSON CommentPage where toJSON cp = toJSON (commentPageComment cp) - -- | helper for conversions cvt :: StringConv a [Char] => a -> H.AttributeValue cvt = fromString . toS @@ -322,7 +244,7 @@ extlink url txt = H.a instance H.ToMarkup CommentPage where toMarkup cp = boilerplate $ do - let sl = unSlug (slug (commentPageComment cp)) + let sl = cp & commentPageComment & val & slug & unSlug cid = commentPageUrl cp H.h2 $ do H.a ! A.href ("/comments/" <> cvt sl <> "#" <> cvt cid) $ H.text "Comment" @@ -351,14 +273,12 @@ instance H.ToMarkup CommentsPage where commentForm (url cp) "anonymous coward" Nothing H.ul $ traverse_ (showChildren (comments cp) (viewTime cp)) (IxSet.toList roots) -fromId :: Id -> UUID -fromId (Id x) = x fromUserId :: UserId -> Text fromUserId (UserId x) = x unSlug :: Slug -> Text unSlug (Slug x) = x -commentForm :: StringConv a [Char] => a -> H.AttributeValue -> (Maybe H.AttributeValue) -> H.Html +commentForm :: StringConv a [Char] => a -> H.AttributeValue -> Maybe H.AttributeValue -> H.Html commentForm slug user mparent = H.form ! A.action "/comments" ! A.method "post" $ do H.input ! A.type_ "hidden" ! A.name "userid" ! A.value user @@ -370,35 +290,95 @@ commentForm slug user mparent = H.br H.input ! A.type_ "submit" ! A.value "add comment" -showChildren :: IxSet.IxSet Comment -> UTCTime -> Comment -> H.Markup +showChildren :: Comments -> UTCTime -> Comment -> H.Markup showChildren cs vt comment = H.li $ displayComment comment vt $ do - let children = cs IxSet.@= ParentId (Just (fromId (id comment))) + let children = cs IxSet.@= ParentId (Just (toS (id comment))) if IxSet.null children then return () else H.ul $ traverse_ (showChildren cs vt) (IxSet.toList children) displayComment :: Comment -> UTCTime -> H.Markup -> H.Markup displayComment comment vt children = do - let inputid = "toggle-" <> UUID.toString (fromId (id comment)) + let inputid = "toggle-" <> UUID.toString (toS (id comment)) H.input ! A.type_ "checkbox" ! A.class_ "toggleinput" ! A.id (cvt inputid) H.div $ do - let cid = UUID.toString (fromId (id comment)) + let cid = UUID.toString (toS (id comment)) H.div ! A.id (cvt cid) ! A.class_ "metas" $ do H.label ! A.for (cvt inputid) ! A.class_ "togglelabel" $ H.span (H.text "[-]") H.a ! A.href (cvt ('#':cid)) $ "ยง " - H.text (fromUserId (userid comment)) + H.text (fromUserId (userid (val comment))) H.span ! A.class_ "time" $ do H.text " - " - H.text . toS . humanReadableDuration . realToFrac $ diffUTCTime vt (created comment) + H.text . toS . humanReadableDuration . realToFrac $ diffUTCTime vt (created (metas comment)) H.text " ago" H.div ! A.class_ "tohide" $ do - H.pre $ H.text (toS (content comment)) + H.pre $ H.text (toS (content (val comment))) H.a ! A.href (cvt ("/comment/" <> cid)) ! A.class_ "small" $ "reply" children +instance SOP.Generic NewComment +instance SOP.HasDatatypeInfo NewComment +deriving instance SQLiteSchemas NewComment -newtype DBConf = DBConf { filePath :: FilePath } +instance FromRow NewComment where fromRow = SQL.genericFromRow -initDB :: DBConf -> IO (DB Comments) -initDB dbConf = Acid.openLocalStateFrom (filePath dbConf) initialComments +instance ToRow NewComment where toRow = SQL.genericToRow + +-- * Usage for DB + +type CommentSQLiteStore = SQLiteStore IO DefaultMetas NewComment +type DBStore = StartedStore CommentSQLiteStore +type CommentConf = DBConf CommentSQLiteStore +type CommentSearchQuery = Search.SearchQuery CommentSQLiteStore +type CommentSearchResult = Search.SearchResult CommentSQLiteStore + +initDBComments :: CommentConf -> IO DBStore +initDBComments = init + +stopDBComments' :: DBStore -> IO () +stopDBComments' = stop + +createComment' :: DBStore -> NewComment -> IO Comment +createComment' = CRUD.create + +readComment' :: DBStore -> Id -> IO (Maybe Comment) +readComment' = CRUD.read + +updateComment' :: DBStore -> Id -> NewComment -> IO (Maybe Comment) +updateComment' = CRUD.update + +deleteComment' :: DBStore -> Id -> IO Bool +deleteComment' = CRUD.delete + +searchComments' :: DBStore -> CommentSearchQuery -> IO CommentSearchResult +searchComments' = Search.search + +getSlugs' :: DBStore -> IO [Slug] +getSlugs' SQLiteState{..} = + liftIO $ query_ conn (conv ("SELECT DISTINCT slug FROM " <> stTablename <> " ORDER BY created LIMIT 100")) + + +-- | A comment handler, handle all impure operations needed to Comments +data CommentHandler = CommentHandler + { createComment :: NewComment -> IO Comment + , readComment :: Id -> IO (Maybe Comment) + , updateComment :: Id -> NewComment -> IO (Maybe Comment) + , deleteComment :: Id -> IO Bool + , searchComments :: CommentSearchQuery -> IO CommentSearchResult + , stopDBComments :: IO () + , getSlugs :: IO [Slug] + } + +-- | Init a new comment handler +newCommentHandler :: CommentConf -> IO CommentHandler +newCommentHandler conf = do + dbstore <- initDBComments conf + pure $ CommentHandler { createComment = createComment' dbstore + , readComment = readComment' dbstore + , updateComment = updateComment' dbstore + , deleteComment = deleteComment' dbstore + , searchComments = searchComments' dbstore + , stopDBComments = stopDBComments' dbstore + , getSlugs = getSlugs' dbstore + } diff --git a/src/Aggreact/Css.hs b/src/Aggreact/Css.hs index ba06758..cdd21e3 100644 --- a/src/Aggreact/Css.hs +++ b/src/Aggreact/Css.hs @@ -1,3 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} -- write "foo" and it will be the correct text type +{-# LANGUAGE NoImplicitPrelude #-} -- to use protolude for example +{-# LANGUAGE ScopedTypeVariables #-} -- write expr :: Type inside an expression +{-# LANGUAGE TupleSections #-} -- (a,,) instead of \x y -> (a,x,y) +{-# LANGUAGE OverloadedLists #-} -- write [1,2,3] :: Set +{-# LANGUAGE ExplicitForAll #-} -- f :: forall a b. a -> b -> b +{-# LANGUAGE RecordWildCards #-} -- f Conf{..} = field1 ... +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- newtype Id = Id Text deriving (StringConv Id String) +{-# LANGUAGE DeriveGeneric #-} -- deriving ToJSON ... +{-# LANGUAGE DerivingStrategies #-} -- remove warn about deriving strategies +{-# LANGUAGE StandaloneDeriving #-} -- write deriving instance ... +{-# LANGUAGE NamedWildCards #-} -- can use _type instead of just _ +{-# LANGUAGE PartialTypeSignatures #-} -- +{-# LANGUAGE BlockArguments #-} -- blabla do ... instead of blabla $ do ... +{-# LANGUAGE NumericUnderscores #-} -- write 1_000 instead of 1000 module Aggreact.Css where import Protolude hiding ((&), div) diff --git a/src/Aggreact/Homepage.hs b/src/Aggreact/Homepage.hs index 93302c8..4c0e451 100644 --- a/src/Aggreact/Homepage.hs +++ b/src/Aggreact/Homepage.hs @@ -1,11 +1,25 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE Strict #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE BlockArguments #-} -- blabla do ... instead of blabla $ do ... +{-# LANGUAGE DeriveGeneric #-} -- deriving ToJSON ... +{-# LANGUAGE DerivingStrategies #-} -- remove warn about deriving strategies +{-# LANGUAGE ExplicitForAll #-} -- f :: forall a b. a -> b -> b +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- newtype Id = Id Text deriving (StringConv Id String) +{-# LANGUAGE NamedWildCards #-} -- can use _type instead of just _ +{-# LANGUAGE NoImplicitPrelude #-} -- to use protolude for example +{-# LANGUAGE NumericUnderscores #-} -- write 1_000 instead of 1000 +{-# LANGUAGE OverloadedLists #-} -- write [1,2,3] :: Set +{-# LANGUAGE OverloadedStrings #-} -- write "foo" and it will be the correct text type +{-# LANGUAGE PartialTypeSignatures #-} -- +{-# LANGUAGE RecordWildCards #-} -- f Conf{..} = field1 ... +{-# LANGUAGE ScopedTypeVariables #-} -- write expr :: Type inside an expression +{-# LANGUAGE StandaloneDeriving #-} -- write deriving instance ... +{-# LANGUAGE Strict #-} -- a la Clojure +{-# LANGUAGE TupleSections #-} -- (a,,) instead of \x y -> (a,x,y) {- | Module : Aggreact.Comments Description : Example of a library file. @@ -25,12 +39,24 @@ module Aggreact.Homepage import Protolude -import Aggreact.Comments (Slug (..), boilerplate) +import Prelude (String) +import Aggreact.Comments (Slug (..)) +import Aggreact.Html (boilerplate) import Data.String (IsString (..)) import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A +import qualified Data.Char as Char +import Text.Printf +encode :: Char -> String +encode c + | c == ' ' = "+" + | Char.isAlphaNum c || c `elem` ("-._~" :: String) = [c] + | otherwise = printf "%%%02X" c + +urlEncode :: String -> String +urlEncode = concatMap encode newtype Homepage = Homepage { topSlugs :: [Slug] } instance H.ToMarkup Homepage where @@ -39,4 +65,4 @@ instance H.ToMarkup Homepage where H.h2 "Latest slugs" H.ul $ traverse_ htmlSlug topSlugs where htmlSlug (Slug s) = - H.li (H.a H.! A.href (fromString (toS ("/comments/" <> s))) $ H.text s) + H.li (H.a H.! A.href (fromString (toS ("/comments/" <> urlEncode (toS s)))) $ H.text s) diff --git a/src/Aggreact/Html.hs b/src/Aggreact/Html.hs new file mode 100644 index 0000000..ed5798d --- /dev/null +++ b/src/Aggreact/Html.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} -- write "foo" and it will be the correct text type +{-# LANGUAGE NoImplicitPrelude #-} -- to use protolude for example +{-# LANGUAGE ScopedTypeVariables #-} -- write expr :: Type inside an expression +{-# LANGUAGE TupleSections #-} -- (a,,) instead of \x y -> (a,x,y) +{-# LANGUAGE OverloadedLists #-} -- write [1,2,3] :: Set +{-# LANGUAGE ExplicitForAll #-} -- f :: forall a b. a -> b -> b +{-# LANGUAGE RecordWildCards #-} -- f Conf{..} = field1 ... +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- newtype Id = Id Text deriving (StringConv Id String) +{-# LANGUAGE DeriveGeneric #-} -- deriving ToJSON ... +{-# LANGUAGE DerivingStrategies #-} -- remove warn about deriving strategies +{-# LANGUAGE StandaloneDeriving #-} -- write deriving instance ... +{-# LANGUAGE NamedWildCards #-} -- can use _type instead of just _ +{-# LANGUAGE PartialTypeSignatures #-} -- +{-# LANGUAGE BlockArguments #-} -- blabla do ... instead of blabla $ do ... +{-# LANGUAGE NumericUnderscores #-} -- write 1_000 instead of 1000 + +{- | +Module : Aggreact.Html +Description : Html helpers for Aggreact +Copyright : (c) 2018, Yann Esposito +License : ISC +Maintainer : yann.esposito@gmail.com +Stability : experimental +Portability : POSIX + +Main datastructures + +-} +module Aggreact.Html + ( boilerplate + ) +where + +import Protolude + +import Text.Blaze.Html5 ((!)) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A + +container :: H.Html -> H.Html +container = H.div ! A.class_ "container" + +boilerplate :: H.Markup -> H.Html +boilerplate innerHtml = + H.html $ do + H.head $ do + H.title (H.text "Aggreact") + H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/main.css" + H.body $ do + H.header . container $ H.a ! A.href "/" $ H.h1 "Aggreact" + container innerHtml + H.footer . container $ do + H.code "Aggreact" + H.text " " + H.span $ do + H.text "done " + H.text " in " + H.a ! A.href "https://haskell.org" $ "Haskell" + H.text " by " + H.a ! A.href "http://yannesposito.com" $ "ye" diff --git a/src/Aggreact/User.hs b/src/Aggreact/User.hs new file mode 100644 index 0000000..fcee83f --- /dev/null +++ b/src/Aggreact/User.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{- | +Module : Aggreact.Store +Description : User Store +Copyright : (c) 2018, Yann Esposito +License : ISC +Maintainer : yann.esposito@gmail.com +Stability : experimental +Portability : POSIX + +Provide a Store abstraction. + +-} + +module Aggreact.User + +where + +import Protolude + +import Database.Store + +data NewUser = NewUser { name :: Text + , email :: Text + } + +type User = Entity DefaultMetas NewUser + diff --git a/src/Database/Store.hs b/src/Database/Store.hs new file mode 100644 index 0000000..52e1a94 --- /dev/null +++ b/src/Database/Store.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- Common +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +{- | +Module : Database.Store +Description : Database.Store lib +Copyright : (c) 2018, Yann Esposito +License : ISC +Maintainer : yann.esposito@gmail.com +Stability : experimental +Portability : POSIX + +Provide Store abstractions. +Stores manage Entities. +Entities have ids and metadatas. + +- @CRUDStore@ abstraction +- @SearchStore@ abstraction + +CRUD Store is a very generic abstraction. +Then there should be backend specific libs. + + +> Database.Store.SQLite +> Database.Store.Postgres +> Database.Store.ACID +> ... + +For each of your datatype @a@ you should simply derive the necessary instances +That might be different depending on the backend you choose. + +-} + +module Database.Store where + +import Protolude + +import Data.Aeson +import Data.Data +import Data.String (IsString (..)) +import Data.Time (UTCTime) +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import qualified Generics.SOP as SOP + +-- | This is the ID type, it is like @Text@. +instance StringConv UUID [Char] where strConv l = strConv l . UUID.toString +instance StringConv UUID Text where strConv l = strConv l . UUID.toText +instance StringConv UUID UUID where strConv _ x = x +instance StringConv UUID Id where strConv l uuid = Id (strConv l uuid) + +instance IsString UUID where + fromString = fromMaybe UUID.nil . UUID.fromString + +newtype Id = Id UUID deriving (Eq,Ord,Show,Generic,Typeable,Data) +instance StringConv Id [Char] where strConv l (Id uuid) = strConv l uuid +instance StringConv Id Text where strConv l (Id uuid) = strConv l uuid +instance StringConv Id UUID where strConv l (Id uuid) = strConv l uuid + +deriving newtype instance ToJSON Id +deriving newtype instance FromJSON Id +deriving newtype instance IsString Id + +-- | We provide a default metas data type +-- only created and updated date +data DefaultMetas = + DefaultMetas + { created :: UTCTime + , updated :: Maybe UTCTime + } deriving (Eq,Ord,Show,Generic,Typeable,Data) + +instance SOP.Generic DefaultMetas +instance SOP.HasDatatypeInfo DefaultMetas + +deriving anyclass instance ToJSON DefaultMetas +deriving anyclass instance FromJSON DefaultMetas + +data Entity ms a = + Entity + { id :: Id + , val :: a + , metas :: ms + } deriving (Generic,Typeable) + +deriving instance (Data ms, Data a) => Data (Entity ms a) +deriving instance (Show ms, Show a) => Show (Entity ms a) +deriving instance (Eq ms, Eq a) => Eq (Entity ms a) +deriving instance (Ord ms, Ord a) => Ord (Entity ms a) +deriving instance (ToJSON ms, ToJSON a) => ToJSON (Entity ms a) + +class Store store m metas entity | store -> m metas entity where + data DBConf store + data StartedStore store + init :: DBConf store -> m (StartedStore store) + stop :: StartedStore store -> m () diff --git a/src/Database/Store/Backend/SQLite.hs b/src/Database/Store/Backend/SQLite.hs new file mode 100644 index 0000000..398beb1 --- /dev/null +++ b/src/Database/Store/Backend/SQLite.hs @@ -0,0 +1,322 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- Common +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | +Module : Database.Store.SQLite +Description : SQLite implentation for Store +Copyright : (c) 2018, Yann Esposito +License : ISC +Maintainer : yann.esposito@gmail.com +Stability : experimental +Portability : POSIX + +Provide a SQLite backend for the Store abstractions: + +- CRUD Store +- Search Store + +To be able to use those stores abstractions on some datatype X you should +implement the following instances for your type X: + +- @SQLiteSchemas@ + +-} + +module Database.Store.Backend.SQLite where + +import Protolude hiding (All, Generic, from, + to) + +import Database.Store +import qualified Database.Store.CRUD as CRUD +import qualified Database.Store.Search as Search + +import Data.String +import qualified Data.Text as Text +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import Database.SQLite.Simple +import Database.SQLite.Simple.FromField +import Database.SQLite.Simple.FromRow +import Database.SQLite.Simple.ToField +import Generics.SOP +import Generics.SOP.Fieldnames +import qualified Generics.SOP.Type.Metadata as T + +conv :: (StringConv a String, IsString b) => a -> b +conv = fromString . toS + +-- | The @SQLiteSchemas@ class should print the SQL part +class SQLiteSchemas a where + sqlSchema :: Proxy a -> [(Text,Text)] + default sqlSchema :: ( HasDatatypeInfo a + , Code a ~ '[ xs ] + , DatatypeInfoOf a ~ 'T.ADT _m _d '[ 'T.Record _c fields ] + , T.DemoteFieldInfos fields xs + , ToSQLiteFieldTypeList xs + ) => Proxy a -> [(Text,Text)] + sqlSchema p = zip (gFields p) (gSqlSchemaTypes p) + updateParams :: a -> [NamedParam] + default updateParams :: ( HasDatatypeInfo a + , Code a ~ '[ xs ] + , DatatypeInfoOf a ~ 'T.ADT _m _d '[ 'T.Record _c fields ] + , T.DemoteFieldInfos fields xs + , Generics.SOP.All ToField xs + ) => a -> [NamedParam] + updateParams = gUpdateParams + + fields :: Proxy a -> [Text] + default fields :: ( HasDatatypeInfo a + , Code a ~ '[ xs ] + , DatatypeInfoOf a ~ 'T.ADT _m _d '[ 'T.Record _c fields ] + , T.DemoteFieldInfos fields xs + ) => Proxy a -> [Text] + fields (Proxy :: Proxy a) = gFields (Proxy :: Proxy a) + + updateFields :: Proxy a -> Text + updateFields = Text.intercalate "," . fmap (\n -> n <> " := :" <> n) . fields + sqlSchemaTxt :: Proxy a -> Text + sqlSchemaTxt = Text.intercalate "," . fmap (\(n,t) -> n <> " " <> t) . sqlSchema + fieldsStr :: Proxy a -> Text + fieldsStr p = Text.intercalate "," (fields p) + questionMarks :: Proxy a -> Text + questionMarks p = Text.intercalate "," (fmap (const "?") (fields p)) + +gUpdateParams :: forall a + (xs :: [*]) + (fields :: [T.FieldInfo]) + (w :: T.ModuleName) + (w1 :: T.DatatypeName) + (w2 :: T.ConstructorName). + ( Generics.SOP.Generic a + , HasDatatypeInfo a + , Code a ~ '[xs] + , DatatypeInfoOf a ~ 'T.ADT w w1 '[ 'T.Record w2 fields] + , T.DemoteFieldInfos fields xs + , Generics.SOP.All ToField xs + ) => a -> [NamedParam] +gUpdateParams r = + let reprec = unZ . unSOP $ Generics.SOP.from r + fns = fieldNames (Proxy :: Proxy a) + in hcollapse $ hczipWith (Proxy :: Proxy ToField) (mapIKK (\v k -> toS k := v)) reprec fns + +gFields :: ( Generics.SOP.Generic a + , Generics.SOP.HasDatatypeInfo a + , Code a ~ '[ xs ] + , DatatypeInfoOf a ~ 'T.ADT m d '[ 'T.Record c fields ] + , T.DemoteFieldInfos fields xs ) + => Proxy a -> [Text] +gFields = fmap toS . hcollapse . fieldNames + + +-- | Generic SQLSchema +gSqlSchemaTypes :: forall a (xs :: [*]). + ( Generics.SOP.Generic a + , Code a ~ '[xs] + , ToSQLiteFieldTypeList xs + ) => Proxy a -> [Text] +gSqlSchemaTypes _ = toSqliteTypes (Proxy @xs) + +class ToSQLiteFieldTypeList (a :: [*]) where + toSqliteTypes :: Proxy a -> [Text] +instance ToSQLiteFieldTypeList '[] where + toSqliteTypes _ = [] +instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Text ': rest) where + toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest) +instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Int ': rest) where + toSqliteTypes _ = "INT":toSqliteTypes (Proxy :: Proxy rest) +instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Id ': rest) where + toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest) + + +-- | Id is an instance of SQLiteSchemas +instance SQLiteSchemas Id where + sqlSchema (Proxy :: Proxy Id) = [("id","TEXT PRIMARY KEY")] + fields (Proxy :: Proxy Id) = ["id"] + updateFields (Proxy :: Proxy Id) = "id = :id" + updateParams i = [":id" := i] + +-- | DefaultMetas is an instance of SQLiteSchemas +instance SQLiteSchemas DefaultMetas where + sqlSchema (Proxy :: Proxy DefaultMetas) = [("created","TEXT"),("updated","TEXT")] + fields = fmap fst . sqlSchema + updateFields = Text.intercalate ", " . fmap (\txt -> txt <> " = :" <> txt) . fields + updateParams DefaultMetas{..} = [ ":created" := created + , ":updated" := updated + ] + +-- | If you provide an instance of @SQLiteSchemas@ for @a@ +-- and @ms@ then we can deduce a the @SQLiteSchemas@ for @Entity ms a@ +instance (SQLiteSchemas a, SQLiteSchemas ms) + => SQLiteSchemas (Entity ms a) where + sqlSchema (Proxy :: Proxy (Entity ms a)) = + sqlSchema (Proxy :: Proxy Id) + <> sqlSchema (Proxy :: Proxy a) + <> sqlSchema (Proxy :: Proxy ms) + updateFields (Proxy :: Proxy (Entity ms a)) = + updateFields (Proxy :: Proxy Id) + <> "," <> updateFields (Proxy :: Proxy a) + <> "," <> updateFields (Proxy :: Proxy ms) + updateParams e = + updateParams (id e) + <> updateParams (val e) + <> updateParams (metas e) + fields (Proxy :: Proxy (Entity ms a)) = + fields (Proxy :: Proxy Id) + <> fields (Proxy :: Proxy a) + <> fields (Proxy :: Proxy ms) + +genericFromRow :: (Generic a, All FromField xs, (Code a) ~ '[xs]) => RowParser a +genericFromRow = to . SOP . Z <$> hsequence (hcpure p field) + where p = Proxy :: Proxy FromField + +genericToRow :: (Generic a, (Code a) ~ '[xs], All ToField xs) => a -> [SQLData] +genericToRow a = + case from a of + (SOP (Z xs)) -> hcollapse (hcliftA p (K . toField . unI) xs) + _ -> panic "THIS CASE SOULD BE PREVENTED BY THE TYPE CONSTRAINTS OF THIS F" + where p = Proxy :: Proxy ToField + +instance ToField Id where + toField (Id i) = SQLText (toS i) + +instance (ToRow a, ToRow ms) => ToRow (Entity ms a) where + toRow e = SQLText (toS (id e)) + : toRow (val e) + <> toRow (metas e :: ms) + +instance FromRow Id where + fromRow = Id . fromString <$> field + +instance (FromRow a, FromRow ms) => FromRow (Entity ms a) where + fromRow = Entity <$> fromRow <*> fromRow <*> fromRow + +data SQLiteStore m ms a + +instance ( MonadIO m + , SQLiteSchemas a + , SQLiteSchemas ms + ) => Store (SQLiteStore m ms a) m ms a where + data DBConf (SQLiteStore m ms a) = + SQLiteConf { dbfilepath :: Text + , tablename :: Text + } + data StartedStore (SQLiteStore m ms a) = + SQLiteState { conn :: Connection + , stTablename :: Text + } + init SQLiteConf{..} = do + conn <- liftIO $ open (toS dbfilepath) + let q :: Query = fromString . toS $ "CREATE TABLE IF NOT EXISTS " <> tablename <> " (" <> sqlSchemaTxt (Proxy :: Proxy (Entity ms a)) <> ")" + void . liftIO $ execute_ conn q + return (SQLiteState { conn = conn + , stTablename = tablename }) + stop = liftIO . close . conn + +instance ( CRUD.CRUDMetas m ms + , MonadIO m + , SQLiteSchemas a + , SQLiteSchemas ms + , FromRow a + , FromRow ms + , ToRow a + , ToRow ms + ) => CRUD.CrudStore (SQLiteStore m ms a) m ms a where + create SQLiteState{..} newEntity = do + cms <- CRUD.creationMetas + newId <- CRUD.genNewId (Proxy :: Proxy ms) + let entity = Entity newId newEntity cms + liftIO $ execute conn + (conv ("INSERT INTO " <> stTablename + <> " (" <> fieldsStr (Proxy :: Proxy (Entity ms a)) + <> ") VALUES (" <> questionMarks (Proxy :: Proxy (Entity ms a)) <> ")")) + entity + return entity + read SQLiteState{..} id = do + result <- liftIO $ query conn (conv ("SELECT * FROM " <> stTablename <> " WHERE id = ?")) (Only id) + case result of + [] -> return Nothing + (r:_) -> return (Just r) + update st@SQLiteState{..} id entity = do + liftIO $ executeNamed conn + (conv ("UPDATE INTO " <> stTablename <> " SET " + <> updateFields (Proxy :: Proxy a) + <> " WHERE " <> updateFields (Proxy :: Proxy Id))) + (updateParams entity <> updateParams id) + CRUD.read st id + delete SQLiteState{..} id = do + liftIO $ execute conn (conv ("DELETE FROM " <> stTablename <> " WHERE id = ?")) (Only id) + nbChanges <- liftIO $ changes conn + return (nbChanges > 0) + +-- * Search Store + +data Pagination = Pagination { limit :: Int + , page :: Int + , orderBy :: [Text]} +data Paginated a = Paginated { results :: [a] + , nbPages :: Int + , currentPage :: Int + } + +instance ( MonadIO m + , SQLiteSchemas a + , SQLiteSchemas ms + , FromRow a + , FromRow ms + ) => Search.SearchStore (SQLiteStore m ms a) m ms a where + data SearchQuery (SQLiteStore m ms a) = Filter { params :: [NamedParam] + -- , pagination :: Pagination + -- , selectedFields :: [Text] + } + data SearchResult (SQLiteStore m ms a) = SR (Paginated (Entity ms a)) + + search SQLiteState{..} Filter{..} = do + let querytxt = conv ("SELECT * FROM " <> stTablename <> " WHERE " <> toQueryTxt params) + results <- liftIO $ queryNamed conn querytxt trparams + return $ SR (Paginated results 1 1) + where + trparams = fmap trNamedParam params + trNamedParam (f := v) = (":" <> f) := v + +toQueryTxt :: [NamedParam] -> Text +toQueryTxt qf = Text.intercalate " AND " (fmap (\np -> let t = fieldOf np in t <> " = :" <> t) qf) + where fieldOf (f := _) = f + + +instance FromField UUID where + fromField f = case fieldData f of + SQLText t -> case UUID.fromText t of + Just uuid -> return uuid + _ -> returnError ConversionFailed f "data is not an UUID" + _ -> returnError ConversionFailed f "need a text" + +instance FromRow DefaultMetas where fromRow = genericFromRow +instance ToRow DefaultMetas where toRow = genericToRow diff --git a/src/Database/Store/CRUD.hs b/src/Database/Store/CRUD.hs new file mode 100644 index 0000000..2a1a137 --- /dev/null +++ b/src/Database/Store/CRUD.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | +Module : Database.Store.CRUD +Description : CRUD Store class +Copyright : (c) 2018, Yann Esposito +License : ISC +Maintainer : yann.esposito@gmail.com +Stability : experimental +Portability : POSIX + +The CRUDStore typeclass + +-} +module Database.Store.CRUD where + +import Protolude + +import qualified Data.Time as Time +import qualified Data.UUID.V4 as UUIDV4 +import Database.Store + +-- | The class @CRUDMetas@ should provide a way to generate +-- ids, set metas at creation, set metas during update +class CRUDMetas m ms where + genNewId :: Proxy ms -> m Id + creationMetas :: m ms + updateMetas :: ms -> m ms + +instance CRUDMetas IO DefaultMetas where + genNewId :: Proxy DefaultMetas -> IO Id + genNewId _ = Id <$> UUIDV4.nextRandom + creationMetas :: IO DefaultMetas + creationMetas = DefaultMetas + <$> Time.getCurrentTime + <*> return Nothing + updateMetas :: DefaultMetas -> IO DefaultMetas + updateMetas oldms = do + now <- Time.getCurrentTime + return $ oldms { updated = Just now } + +class ( Store s m ms a + , CRUDMetas m ms + ) => CrudStore s m ms a | s -> m ms a where + create :: StartedStore s -> a -> m (Entity ms a) + read :: StartedStore s -> Id -> m (Maybe (Entity ms a)) + update :: StartedStore s -> Id -> a -> m (Maybe (Entity ms a)) + delete :: StartedStore s -> Id -> m Bool diff --git a/src/Database/Store/Search.hs b/src/Database/Store/Search.hs new file mode 100644 index 0000000..3d69b29 --- /dev/null +++ b/src/Database/Store/Search.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Database.Store.Search where + +import Database.Store + +-- e is for Entity type (without metas) +-- ms is the type for meta datas +-- m is for the monad into which the search can occur +-- s is the store type +class (Store s m ms e) => SearchStore s m ms e where + data SearchQuery s + data SearchResult s + search :: StartedStore s -> SearchQuery s -> m (SearchResult s) diff --git a/src/DevelMain.hs b/src/DevelMain.hs index 6f730e9..8012509 100644 --- a/src/DevelMain.hs +++ b/src/DevelMain.hs @@ -18,7 +18,7 @@ module DevelMain where import Protolude -import Aggreact (Conf (..), initialize, shutdownApp) +import Aggreact (initialize, shutdownApp) import Control.Concurrent (MVar, ThreadId, forkIO, killThread, newEmptyMVar, putMVar, takeMVar) @@ -31,6 +31,7 @@ import Foreign.Store (Store (..), lookupStore, readStore, import GHC.Word (Word32) import Network.Wai.Handler.Warp (defaultSettings, runSettings, setPort) +import Database.Store.Backend.SQLite (DBConf (SQLiteConf)) -- | Start or restart the server. -- newStore is from foreign-store. @@ -63,9 +64,9 @@ update = do start :: MVar () -- ^ Written to when the thread is killed. -> IO ThreadId start done = do - (config, app) <- initialize - forkIO (finally (runSettings (setPort (port config) defaultSettings) app) - (shutdownApp config >> putMVar done ())) + (commentHandler, app) <- initialize (SQLiteConf "aggreact.db" "comments") + forkIO (finally (runSettings (setPort 3000 defaultSettings) app) + (shutdownApp commentHandler >> putMVar done ())) -- | kill the server shutdown :: IO () diff --git a/src/Generics/SOP/Fieldnames.hs b/src/Generics/SOP/Fieldnames.hs new file mode 100644 index 0000000..fc8a68d --- /dev/null +++ b/src/Generics/SOP/Fieldnames.hs @@ -0,0 +1,58 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Generics.SOP.Fieldnames where + +import Prelude + +import Generics.SOP +import qualified Generics.SOP.Type.Metadata as T + +fieldInfos :: + forall a xs fields _m _d _c . + ( Generic a + , Code a ~ '[ xs ] + , DatatypeInfoOf a ~ 'T.ADT _m _d '[ 'T.Record _c fields ] + , T.DemoteFieldInfos fields xs + ) => Proxy a -> NP FieldInfo xs +fieldInfos _ = T.demoteFieldInfos (Proxy @fields) + +fieldNames :: + forall a xs fields _m _d _c . + ( Generic a + , Code a ~ '[ xs ] + , DatatypeInfoOf a ~ 'T.ADT _m _d '[ 'T.Record _c fields ] + , T.DemoteFieldInfos fields xs + ) => Proxy a -> NP (K String) xs +fieldNames = hmap (K . fieldName) . fieldInfos + +{- +* Examples + +data Foo = Foo { name :: String, age :: Int } deriving (GHC.Generics.Generic) +instance Generics.SOP.Generic Foo +instance Generics.SOP.HasDatatypeInfo Foo + +>>> fieldNamesfoo = fieldNames (Proxy :: Proxy Foo) +K "name" :* K "age" :* Nil + +>>> foo = Foo "test" 10 + +>>> from foo +SOP (Z (I "test" :* I 10 :* Nil)) + +>>> unZ . unSOP $ from foo +I "test" :* I 10 :* Nil + +>>> res = (hcollapse . hcmap (Proxy :: Proxy Show) (mapIK show) . from) foo +res = ["test","10"] + +-} diff --git a/src/Servant/Clay.hs b/src/Servant/Clay.hs index c5c8c1b..344eafc 100644 --- a/src/Servant/Clay.hs +++ b/src/Servant/Clay.hs @@ -3,6 +3,22 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE BlockArguments #-} -- blabla do ... instead of blabla $ do ... +{-# LANGUAGE DeriveGeneric #-} -- deriving ToJSON ... +{-# LANGUAGE DerivingStrategies #-} -- remove warn about deriving strategies +{-# LANGUAGE ExplicitForAll #-} -- f :: forall a b. a -> b -> b +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- newtype Id = Id Text deriving (StringConv Id String) +{-# LANGUAGE NamedWildCards #-} -- can use _type instead of just _ +{-# LANGUAGE NoImplicitPrelude #-} -- to use protolude for example +{-# LANGUAGE NumericUnderscores #-} -- write 1_000 instead of 1000 +{-# LANGUAGE OverloadedLists #-} -- write [1,2,3] :: Set +{-# LANGUAGE OverloadedStrings #-} -- write "foo" and it will be the correct text type +{-# LANGUAGE PartialTypeSignatures #-} -- +{-# LANGUAGE RecordWildCards #-} -- f Conf{..} = field1 ... +{-# LANGUAGE ScopedTypeVariables #-} -- write expr :: Type inside an expression +{-# LANGUAGE StandaloneDeriving #-} -- write deriving instance ... +{-# LANGUAGE Strict #-} -- a la Clojure +{-# LANGUAGE TupleSections #-} -- (a,,) instead of \x y -> (a,x,y) module Servant.Clay where import Protolude hiding (encodeUtf8) diff --git a/stack.yaml b/stack.yaml index 5533ea9..24a0baf 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,7 +18,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-12.20 +resolver: lts-13.0 # User packages to be built. # Various formats can be used as shown in the example below. @@ -35,6 +35,7 @@ resolver: lts-12.20 # - wai packages: - . +# - '../sqlite-simple' # Dependency packages to be pulled from upstream that are not in the resolver # using the same syntax as the packages field. # (e.g., acme-missiles-0.3) @@ -43,7 +44,6 @@ extra-deps: - syb-with-class-0.6.1.10 - acid-state-0.14.3 - # Override default flag values for local packages and extra-deps # flags: {} @@ -67,3 +67,6 @@ extra-deps: # # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor + +# for intero and 8.6.1 +allow-newer: true