yogsototh/aggreact
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

refacto of code

Browse source 
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
This commit is contained in:
Yann Esposito (Yogsototh) 2018-12-26 18:31:55 +01:00
parent 8c87c7a1df
commit 1bf856ea09
Signed by untrusted user who does not match committer: yogsototh
GPG key ID: 7B19A4C650D59646
23 changed files with 1294 additions and 297 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
.dir-locals.el Normal file
View file

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

1
.gitignore vendored
View file

@ -2,3 +2,4 @@
/.stack-work/
state/
dist-newstyle/
*.db

29
aggreact.cabal
View file

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

5
auto-test.sh Executable file
View file

@ -0,0 +1,5 @@
#!/bin/bash
target="aggreact:test:aggreact-test"
ghcid \
--command "stack ghci $target --ghci-options=-fobject-code" \
--test "main"

17
package.yaml
View file

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

2
repl.sh Executable file
View file

@ -0,0 +1,2 @@
#!/bin/bash
stack ghci --ghci-options "-interactive-print=Text.Pretty.Simple.pPrint" --package pretty-simple

9
src-exe/Main.hs
View file

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

111
src-test/Database/Store/Backend/SQLiteTest.hs Normal file
View file

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

17
src-test/Main.hs
View file

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

193
src/Aggreact.hs
View file

@ -4,6 +4,20 @@
{-# 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
Description : Example of a library file.
@ -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.Homepage
import Clay (Css)
import qualified Data.Acid as Acid
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)

386
src/Aggreact/Comments.hs
View file

@ -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 Aggreact.Html (boilerplate)
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.Aeson (FromJSON (..), 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 qualified Data.IxSet.Typed as IxSet
import Data.String (IsString (..))
import qualified Data.Text as Text
import Data.Time (UTCTime, diffUTCTime,
getCurrentTime)
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 qualified Data.UUID.V4 as UUIDV4
import qualified Text.Blaze.Html5 as H
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)
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
}

15
src/Aggreact/Css.hs
View file

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

34
src/Aggreact/Homepage.hs
View file

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

60
src/Aggreact/Html.hs Normal file
View file

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

33
src/Aggreact/User.hs Normal file
View file

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

117
src/Database/Store.hs Normal file
View file

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

322
src/Database/Store/Backend/SQLite.hs Normal file
View file

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

62
src/Database/Store/CRUD.hs Normal file
View file

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

26
src/Database/Store/Search.hs Normal file
View file

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

9
src/DevelMain.hs
View file

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

58
src/Generics/SOP/Fieldnames.hs Normal file
View file

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

16
src/Servant/Clay.hs
View file

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

7
stack.yaml
View file

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