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