refacto of code
Type level black magic! better naming Even darker type level programming black magic Fix the updatefields Updated to usage typeclasses structure update the Comments file Added a working function ignore .db files It's happening! Using the Handler pattern Added search, need to think about non generic queries Fixes, but unsatisfactory about search Working system Fixed tests Fixed search to make it safer Cleaner test Added Show instances (will help for debug) working code add auto-test.sh script Use ixset-typed for more typesafety Working system with a "hole" in the abstraction
This commit is contained in:
parent
8c87c7a1df
commit
1bf856ea09
23 changed files with 1294 additions and 297 deletions
6
.dir-locals.el
Normal file
6
.dir-locals.el
Normal 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
1
.gitignore
vendored
|
@ -2,3 +2,4 @@
|
||||||
/.stack-work/
|
/.stack-work/
|
||||||
state/
|
state/
|
||||||
dist-newstyle/
|
dist-newstyle/
|
||||||
|
*.db
|
|
@ -2,7 +2,7 @@
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: 60fed7e68e1912e16f4c7e8cbf3baa477d6f37f6fb2c1e9c9f8493ca56bcb746
|
-- hash: 9783f1aaf5e0695e9390f197cf2cbabe82e032dc7319e7e43ba82db01a24dded
|
||||||
|
|
||||||
name: aggreact
|
name: aggreact
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
|
@ -31,13 +31,20 @@ library
|
||||||
Aggreact.Comments
|
Aggreact.Comments
|
||||||
Aggreact.Css
|
Aggreact.Css
|
||||||
Aggreact.Homepage
|
Aggreact.Homepage
|
||||||
|
Aggreact.Html
|
||||||
|
Aggreact.User
|
||||||
|
Database.Store
|
||||||
|
Database.Store.Backend.SQLite
|
||||||
|
Database.Store.CRUD
|
||||||
|
Database.Store.Search
|
||||||
DevelMain
|
DevelMain
|
||||||
|
Generics.SOP.Fieldnames
|
||||||
Servant.Clay
|
Servant.Clay
|
||||||
other-modules:
|
other-modules:
|
||||||
Paths_aggreact
|
Paths_aggreact
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
src
|
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
|
ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -Werror -O2
|
||||||
build-depends:
|
build-depends:
|
||||||
acid-state
|
acid-state
|
||||||
|
@ -50,15 +57,19 @@ library
|
||||||
, clay
|
, clay
|
||||||
, containers
|
, containers
|
||||||
, foreign-store
|
, foreign-store
|
||||||
|
, generics-sop
|
||||||
, http-api-data
|
, http-api-data
|
||||||
, http-media
|
, http-media
|
||||||
, human-readable-duration
|
, human-readable-duration
|
||||||
, ixset
|
, ixset-typed
|
||||||
, protolude
|
, protolude
|
||||||
, safecopy
|
, safecopy
|
||||||
, servant
|
, servant
|
||||||
|
, servant-auth
|
||||||
|
, servant-auth-server
|
||||||
, servant-blaze
|
, servant-blaze
|
||||||
, servant-server
|
, servant-server
|
||||||
|
, sqlite-simple
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
, uuid
|
, uuid
|
||||||
|
@ -72,7 +83,7 @@ executable aggreact
|
||||||
Paths_aggreact
|
Paths_aggreact
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
src-exe
|
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"
|
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:
|
build-depends:
|
||||||
aggreact
|
aggreact
|
||||||
|
@ -87,7 +98,7 @@ test-suite aggreact-doctest
|
||||||
Paths_aggreact
|
Paths_aggreact
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
src-doctest
|
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
|
ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
|
||||||
build-depends:
|
build-depends:
|
||||||
Glob >=0.7
|
Glob >=0.7
|
||||||
|
@ -102,15 +113,19 @@ test-suite aggreact-test
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
other-modules:
|
other-modules:
|
||||||
|
Database.Store.Backend.SQLiteTest
|
||||||
Paths_aggreact
|
Paths_aggreact
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
src-test
|
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
|
ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
|
||||||
build-depends:
|
build-depends:
|
||||||
aggreact
|
aggreact
|
||||||
, base >=4.8 && <5
|
, base >=4.8 && <5
|
||||||
|
, directory
|
||||||
|
, generics-sop
|
||||||
, protolude
|
, protolude
|
||||||
|
, sqlite-simple
|
||||||
, tasty >=0.11
|
, tasty >=0.11
|
||||||
, tasty-hunit >=0.9
|
, tasty-hunit >=0.9
|
||||||
, tasty-smallcheck >=0.8
|
, tasty-smallcheck >=0.8
|
||||||
|
@ -123,7 +138,7 @@ benchmark aggreact-benchmark
|
||||||
Paths_aggreact
|
Paths_aggreact
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
src-benchmark
|
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
|
ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
|
||||||
build-depends:
|
build-depends:
|
||||||
aggreact
|
aggreact
|
||||||
|
|
5
auto-test.sh
Executable file
5
auto-test.sh
Executable 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
17
package.yaml
|
@ -22,10 +22,10 @@ default-extensions:
|
||||||
- DerivingStrategies # remove warn about deriving strategies
|
- DerivingStrategies # remove warn about deriving strategies
|
||||||
- StandaloneDeriving # write deriving instance ...
|
- StandaloneDeriving # write deriving instance ...
|
||||||
# need GHC > 8.6
|
# need GHC > 8.6
|
||||||
# - NamedWildcard # can use _type instead of just _
|
- NamedWildCards # can use _type instead of just _
|
||||||
# - PartialTypeSignature
|
- PartialTypeSignatures
|
||||||
# - BlockArguments # blabla do ... instead of blabla $ do ...
|
- BlockArguments # blabla do ... instead of blabla $ do ...
|
||||||
# - NumericUnderscores # write 1_000 instead of 1000
|
- NumericUnderscores # write 1_000 instead of 1000
|
||||||
ghc-options:
|
ghc-options:
|
||||||
- -Wall
|
- -Wall
|
||||||
- -Wcompat
|
- -Wcompat
|
||||||
|
@ -52,11 +52,15 @@ library:
|
||||||
- http-api-data
|
- http-api-data
|
||||||
- http-media
|
- http-media
|
||||||
- human-readable-duration
|
- human-readable-duration
|
||||||
- ixset
|
- ixset-typed
|
||||||
|
- generics-sop
|
||||||
- safecopy
|
- safecopy
|
||||||
- servant
|
- servant
|
||||||
|
- servant-auth
|
||||||
|
- servant-auth-server
|
||||||
- servant-blaze
|
- servant-blaze
|
||||||
- servant-server
|
- servant-server
|
||||||
|
- sqlite-simple
|
||||||
- text
|
- text
|
||||||
- time
|
- time
|
||||||
- uuid
|
- uuid
|
||||||
|
@ -98,6 +102,9 @@ tests:
|
||||||
- tasty-hunit >=0.9
|
- tasty-hunit >=0.9
|
||||||
- tasty-smallcheck >=0.8
|
- tasty-smallcheck >=0.8
|
||||||
- aggreact
|
- aggreact
|
||||||
|
- generics-sop
|
||||||
|
- sqlite-simple
|
||||||
|
- directory
|
||||||
benchmarks:
|
benchmarks:
|
||||||
aggreact-benchmark:
|
aggreact-benchmark:
|
||||||
main: Main.hs
|
main: Main.hs
|
||||||
|
|
2
repl.sh
Executable file
2
repl.sh
Executable file
|
@ -0,0 +1,2 @@
|
||||||
|
#!/bin/bash
|
||||||
|
stack ghci --ghci-options "-interactive-print=Text.Pretty.Simple.pPrint" --package pretty-simple
|
|
@ -1,9 +1,10 @@
|
||||||
import Protolude
|
import Protolude
|
||||||
|
|
||||||
import Aggreact (mainServe,Conf(..))
|
import Aggreact (mainServe,Conf(..),initialize)
|
||||||
import Aggreact.Comments (initDB,DBConf(..))
|
import Database.Store.Backend.SQLite (DBConf (SQLiteConf))
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
db <- initDB (DBConf "state")
|
let conf = Conf 3000 (SQLiteConf "aggreact.db" "comments")
|
||||||
mainServe db (Conf 3000 db)
|
(ch,_) <- initialize (commentConf conf)
|
||||||
|
mainServe ch conf
|
||||||
|
|
111
src-test/Database/Store/Backend/SQLiteTest.hs
Normal file
111
src-test/Database/Store/Backend/SQLiteTest.hs
Normal 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
|
|
@ -1,20 +1,27 @@
|
||||||
import Protolude
|
import Protolude
|
||||||
|
|
||||||
import Test.Tasty
|
import Test.Tasty
|
||||||
import Test.Tasty.HUnit
|
-- import Test.Tasty.HUnit
|
||||||
import Test.Tasty.SmallCheck
|
-- import Test.Tasty.SmallCheck
|
||||||
|
|
||||||
import Lib (inc)
|
import Database.Store.Backend.SQLiteTest
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = defaultMain $ testGroup "all-tests" tests
|
main = defaultMain $ testGroup "all-tests" tests
|
||||||
|
|
||||||
|
tests :: [TestTree]
|
||||||
|
tests =
|
||||||
|
[ testGroup "SQLite Store" testSQLiteGenerics
|
||||||
|
, testGroup "SQLite CRUD Store" testSQLiteCRUD
|
||||||
|
]
|
||||||
|
|
||||||
|
{-
|
||||||
|
|
||||||
tests :: [TestTree]
|
tests :: [TestTree]
|
||||||
tests =
|
tests =
|
||||||
[ testGroup "SmallCheck" scTests
|
[ testGroup "SmallCheck" scTests
|
||||||
, testGroup "Unit tests" huTests
|
, testGroup "Unit tests" huTests
|
||||||
]
|
]
|
||||||
|
|
||||||
scTests :: [TestTree]
|
scTests :: [TestTree]
|
||||||
scTests =
|
scTests =
|
||||||
[ testProperty "inc == succ" prop_succ
|
[ testProperty "inc == succ" prop_succ
|
||||||
|
@ -38,3 +45,5 @@ case_inc_below = inc 41 @?= (42 :: Int)
|
||||||
|
|
||||||
case_dec_above :: Assertion
|
case_dec_above :: Assertion
|
||||||
case_dec_above = negate (inc (negate 43)) @?= (42 :: Int)
|
case_dec_above = negate (inc (negate 43)) @?= (42 :: Int)
|
||||||
|
|
||||||
|
-}
|
||||||
|
|
215
src/Aggreact.hs
215
src/Aggreact.hs
|
@ -1,8 +1,22 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE Strict #-}
|
{-# LANGUAGE Strict #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE TypeSynonymInstances #-}
|
{-# 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
|
Module : Aggreact
|
||||||
|
@ -23,24 +37,136 @@ module Aggreact
|
||||||
, Conf (..)
|
, Conf (..)
|
||||||
, initialize
|
, initialize
|
||||||
, shutdownApp
|
, shutdownApp
|
||||||
|
, mainWithCookies
|
||||||
|
, mainWithJWT
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Protolude
|
import Protolude
|
||||||
|
|
||||||
import Aggreact.Homepage
|
|
||||||
import Aggreact.Comments
|
import Aggreact.Comments
|
||||||
import Aggreact.Css (genCss)
|
import Aggreact.Css (genCss)
|
||||||
|
import Aggreact.Homepage
|
||||||
|
|
||||||
import Clay (Css)
|
import Clay (Css)
|
||||||
import qualified Data.Acid as Acid
|
import Data.Aeson
|
||||||
import Data.Time (getCurrentTime)
|
import qualified Data.IxSet.Typed as IxSet
|
||||||
import qualified Data.UUID as UUID
|
import Data.Time (getCurrentTime)
|
||||||
import Network.Wai (Application)
|
import qualified Data.UUID as UUID
|
||||||
import qualified Network.Wai.Handler.Warp as Warp
|
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
|
||||||
import Servant.Clay
|
import Servant.Clay
|
||||||
import Servant.HTML.Blaze
|
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
|
type CommentAPI = Get '[HTML] Homepage
|
||||||
:<|> "comments" :> Capture "slug" Text :> Get '[HTML,JSON] CommentsPage
|
:<|> "comments" :> Capture "slug" Text :> Get '[HTML,JSON] CommentsPage
|
||||||
:<|> "slugs" :> Get '[JSON] [Slug]
|
:<|> "slugs" :> Get '[JSON] [Slug]
|
||||||
|
@ -48,52 +174,47 @@ type CommentAPI = Get '[HTML] Homepage
|
||||||
:<|> "comments" :> ReqBody '[JSON, FormUrlEncoded] NewComment :> Post '[JSON] Comment
|
:<|> "comments" :> ReqBody '[JSON, FormUrlEncoded] NewComment :> Post '[JSON] Comment
|
||||||
:<|> "comment" :> Capture "commentId" Text :> Get '[HTML,JSON] CommentPage
|
:<|> "comment" :> Capture "commentId" Text :> Get '[HTML,JSON] CommentPage
|
||||||
|
|
||||||
data Conf = Conf { port :: Int
|
handlers :: CommentHandler -> Server CommentAPI
|
||||||
, dbcomments :: DB Comments }
|
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 :: CommentHandler -> Text -> Handler CommentsPage
|
||||||
showComments db s = do
|
showComments CommentHandler{..} s = do
|
||||||
cs <- liftIO . getCommentsBySlug db . Slug $ s
|
(SR (Paginated cs _ _)) <- liftIO $
|
||||||
|
searchComments Filter {params = ["slug" := Slug s]}
|
||||||
now <- liftIO getCurrentTime
|
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 :: CommentHandler -> Text -> Handler CommentPage
|
||||||
showComment db i =
|
showComment CommentHandler{..} i =
|
||||||
case UUID.fromText i of
|
case UUID.fromText i of
|
||||||
Nothing -> throwError err404
|
Nothing -> throwError err404
|
||||||
Just uuid -> do
|
Just uuid -> do
|
||||||
cs <- liftIO . getCommentById db . Id $ uuid
|
cs <- liftIO . readComment . Id $ uuid
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
case cs of
|
case cs of
|
||||||
Just c -> return CommentPage { commentPageUrl = i, commentPageViewTime = now, commentPageComment = c }
|
Just c -> return CommentPage { commentPageUrl = i, commentPageViewTime = now, commentPageComment = c }
|
||||||
_ -> throwError err404
|
_ -> throwError err404
|
||||||
|
|
||||||
listSlugs :: DB Comments -> Handler [Slug]
|
commentAPI :: Proxy CommentAPI
|
||||||
listSlugs = liftIO . slugs
|
commentAPI = Proxy
|
||||||
|
|
||||||
api :: Proxy CommentAPI
|
app :: CommentHandler -> Application
|
||||||
api = Proxy
|
app db = serve commentAPI (handlers db)
|
||||||
|
|
||||||
server :: DB Comments -> Server CommentAPI
|
initialize :: CommentConf -> IO (CommentHandler,Application)
|
||||||
server db =
|
initialize conf = do
|
||||||
Homepage <$> listSlugs db
|
commentHandler <- newCommentHandler conf
|
||||||
:<|> showComments db
|
return (commentHandler,app commentHandler)
|
||||||
:<|> listSlugs db
|
|
||||||
:<|> return genCss
|
|
||||||
:<|> liftIO . createNewComment db
|
|
||||||
:<|> showComment db
|
|
||||||
|
|
||||||
app :: DB Comments -> Application
|
shutdownApp :: CommentHandler -> IO ()
|
||||||
app db = serve api (server db)
|
shutdownApp CommentHandler{..} = stopDBComments
|
||||||
|
|
||||||
initialize :: IO (Conf, Application)
|
mainServe :: CommentHandler -> Conf -> IO ()
|
||||||
initialize = do
|
mainServe ch conf = Warp.run (port conf) (app ch)
|
||||||
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)
|
|
||||||
|
|
|
@ -1,19 +1,31 @@
|
||||||
{-# LANGUAGE DerivingStrategies #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
{-# LANGUAGE DeriveAnyClass #-}
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
|
||||||
{-# LANGUAGE Strict #-}
|
{-# LANGUAGE Strict #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeSynonymInstances #-}
|
{-# 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
|
Module : Aggreact.Comments
|
||||||
Description : Example of a library file.
|
Description : Example of a library file.
|
||||||
|
@ -29,8 +41,7 @@ Main datastructures
|
||||||
module Aggreact.Comments
|
module Aggreact.Comments
|
||||||
(
|
(
|
||||||
-- * Types
|
-- * Types
|
||||||
Id (..)
|
Comment
|
||||||
, Comment (..)
|
|
||||||
, CommentPage (..)
|
, CommentPage (..)
|
||||||
, CommentsPage (..)
|
, CommentsPage (..)
|
||||||
, NewComment (..)
|
, NewComment (..)
|
||||||
|
@ -38,67 +49,70 @@ module Aggreact.Comments
|
||||||
, Slug (..)
|
, Slug (..)
|
||||||
, ParentId (..)
|
, ParentId (..)
|
||||||
, UserId (..)
|
, UserId (..)
|
||||||
, DB
|
-- * Usage for DB
|
||||||
, DBConf (..)
|
, CommentConf
|
||||||
-- * Operations
|
, newCommentHandler
|
||||||
, initDB
|
, CommentHandler(..)
|
||||||
, createNewComment
|
|
||||||
, slugs
|
|
||||||
, getCommentsBySlug
|
|
||||||
, getCommentsByParentId
|
|
||||||
, getCommentById
|
|
||||||
-- * HTML
|
-- * HTML
|
||||||
, boilerplate
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Protolude hiding (get, put)
|
import Protolude hiding (get, put)
|
||||||
|
|
||||||
import qualified Control.Exception as Ex
|
import Aggreact.Html (boilerplate)
|
||||||
import Data.Acid (AcidState, Query, Update,
|
|
||||||
makeAcidic)
|
import qualified Control.Exception as Ex
|
||||||
import qualified Data.Acid as Acid
|
import Data.Aeson (FromJSON (..), ToJSON (..),
|
||||||
import Data.Aeson (FromJSON (..), Options (..),
|
defaultOptions,
|
||||||
ToJSON (..), defaultOptions,
|
genericParseJSON,
|
||||||
genericParseJSON, genericToJSON)
|
genericToJSON)
|
||||||
import Data.Char (isAlphaNum)
|
import Data.Char (isAlphaNum)
|
||||||
import Data.Data (Data (..))
|
import Data.Data (Data (..))
|
||||||
import Data.Duration (humanReadableDuration)
|
import Data.Duration (humanReadableDuration)
|
||||||
import qualified Data.IxSet as IxSet
|
import qualified Data.IxSet.Typed as IxSet
|
||||||
import Data.SafeCopy (base, deriveSafeCopy)
|
import Data.String (IsString (..))
|
||||||
import Data.Serialize (Serialize (..))
|
import qualified Data.Text as Text
|
||||||
import Data.Serialize.Text ()
|
import Data.Time (UTCTime, diffUTCTime)
|
||||||
import Data.String (IsString (..))
|
import Database.SQLite.Simple.FromField (FromField (..))
|
||||||
import qualified Data.Text as Text
|
import Database.SQLite.Simple.ToField (ToField (..))
|
||||||
import Data.Time (UTCTime, diffUTCTime,
|
import Database.SQLite.Simple.FromRow (FromRow(..),field)
|
||||||
getCurrentTime)
|
import Database.SQLite.Simple.ToRow (ToRow(..))
|
||||||
import Data.Time.Clock.Serialize ()
|
import Database.SQLite.Simple (SQLData(..),query_)
|
||||||
import Data.Time.Format ()
|
|
||||||
import Data.Typeable (Typeable)
|
import Data.Time.Clock.Serialize ()
|
||||||
import Data.UUID (UUID)
|
import Data.Time.Format ()
|
||||||
import qualified Data.UUID as UUID
|
import Data.Typeable (Typeable)
|
||||||
import qualified Data.UUID.V4 as UUIDV4
|
import Data.UUID (UUID)
|
||||||
import qualified Text.Blaze.Html5 as H
|
import qualified Data.UUID as UUID
|
||||||
import Text.Blaze.Html5 ((!))
|
import Database.Store (Id(..), DefaultMetas (..), Entity (..), Store(..))
|
||||||
import qualified Text.Blaze.Html5.Attributes as A
|
import Database.Store.Backend.SQLite as SQL
|
||||||
import qualified Web.FormUrlEncoded as Form
|
import qualified Database.Store.CRUD as CRUD
|
||||||
import qualified Web.HttpApiData as FormI
|
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
|
-- * 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
|
instance ( Ord a
|
||||||
, ToJSON a
|
, ToJSON a
|
||||||
, IxSet.Indexable a
|
, IxSet.Indexable ixs a
|
||||||
, Typeable a) => ToJSON (IxSet.IxSet a) where
|
, Typeable a) => ToJSON (IxSet.IxSet ixs a) where
|
||||||
toJSON i = toJSON (IxSet.toList i)
|
toJSON i = toJSON (IxSet.toList i)
|
||||||
|
|
||||||
-- * Comment
|
-- * Comment
|
||||||
|
@ -106,64 +120,61 @@ instance ( Ord a
|
||||||
data DecodeUUIDException = DecodeUUIDException deriving (Show)
|
data DecodeUUIDException = DecodeUUIDException deriving (Show)
|
||||||
instance Ex.Exception DecodeUUIDException
|
instance Ex.Exception DecodeUUIDException
|
||||||
|
|
||||||
unsecureFromJust :: Maybe a -> a
|
newtype ParentId = ParentId (Maybe UUID) deriving (Eq,Ord,Show,Generic,Data)
|
||||||
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)
|
|
||||||
deriving anyclass instance FromJSON ParentId
|
deriving anyclass instance FromJSON ParentId
|
||||||
deriving anyclass instance ToJSON 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 [Char] where strConv l (Slug sl) = strConv l sl
|
||||||
instance StringConv Slug Text 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 FromJSON Slug
|
||||||
deriving anyclass instance ToJSON 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 [Char] where strConv l (UserId sl) = strConv l sl
|
||||||
instance StringConv UserId Text 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 FromJSON UserId
|
||||||
deriving anyclass instance ToJSON 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 [Char] where strConv l (Content sl) = strConv l sl
|
||||||
instance StringConv Content Text 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 FromJSON Content
|
||||||
deriving anyclass instance ToJSON 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 =
|
data NewComment =
|
||||||
NewComment
|
NewComment
|
||||||
{ ncparent :: Maybe ParentId
|
{ parent :: ParentId
|
||||||
, ncslug :: Slug
|
, slug :: Slug
|
||||||
, nccontent :: Content
|
, content :: Content
|
||||||
, ncuserid :: UserId
|
, userid :: UserId
|
||||||
} deriving (Generic,Typeable,Eq,Ord)
|
} deriving (Generic,Typeable,Data,Eq,Ord,Show)
|
||||||
|
|
||||||
instance FromJSON NewComment where
|
instance FromJSON NewComment where
|
||||||
parseJSON = genericParseJSON (defaultOptions { fieldLabelModifier = drop 2})
|
parseJSON = genericParseJSON defaultOptions
|
||||||
instance ToJSON NewComment where
|
instance ToJSON NewComment where
|
||||||
toJSON = genericToJSON (defaultOptions { fieldLabelModifier = drop 2})
|
toJSON = genericToJSON defaultOptions
|
||||||
|
|
||||||
instance FormI.FromHttpApiData ParentId where
|
instance FormI.FromHttpApiData ParentId where
|
||||||
parseUrlPiece s = do
|
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 Content where parseUrlPiece = fmap Content . FormI.parseUrlPiece
|
||||||
instance FormI.FromHttpApiData UserId where parseUrlPiece = fmap UserId . FormI.parseUrlPiece
|
instance FormI.FromHttpApiData UserId where parseUrlPiece = fmap UserId . FormI.parseUrlPiece
|
||||||
instance Form.FromForm NewComment where
|
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
|
type NewCommentIxs = '[ParentId,Slug,Content,UserId,Term]
|
||||||
deriving instance Serialize Comment
|
instance IxSet.Indexable NewCommentIxs Comment where
|
||||||
deriving instance Data Comment
|
indices = IxSet.ixList
|
||||||
instance IxSet.Indexable Comment where
|
(IxSet.ixGen (Proxy :: Proxy ParentId))
|
||||||
empty =
|
(IxSet.ixGen (Proxy :: Proxy Slug))
|
||||||
IxSet.ixSet
|
(IxSet.ixGen (Proxy :: Proxy Content))
|
||||||
[ IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy Id)
|
(IxSet.ixGen (Proxy :: Proxy UserId))
|
||||||
, IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy ParentId)
|
(IxSet.ixFun getTerms)
|
||||||
, IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy Slug)
|
|
||||||
, IxSet.ixGen (IxSet.Proxy :: IxSet.Proxy UserId)
|
type Comment = Entity DefaultMetas NewComment
|
||||||
, IxSet.ixFun getTerms -- Ability to search content text
|
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 :: 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
|
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
|
-- * 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 =
|
data CommentPage =
|
||||||
CommentPage
|
CommentPage
|
||||||
{ commentPageUrl :: Text
|
{ commentPageUrl :: Text
|
||||||
|
@ -306,7 +229,6 @@ data CommentPage =
|
||||||
instance ToJSON CommentPage where
|
instance ToJSON CommentPage where
|
||||||
toJSON cp = toJSON (commentPageComment cp)
|
toJSON cp = toJSON (commentPageComment cp)
|
||||||
|
|
||||||
|
|
||||||
-- | helper for conversions
|
-- | helper for conversions
|
||||||
cvt :: StringConv a [Char] => a -> H.AttributeValue
|
cvt :: StringConv a [Char] => a -> H.AttributeValue
|
||||||
cvt = fromString . toS
|
cvt = fromString . toS
|
||||||
|
@ -322,7 +244,7 @@ extlink url txt = H.a
|
||||||
|
|
||||||
instance H.ToMarkup CommentPage where
|
instance H.ToMarkup CommentPage where
|
||||||
toMarkup cp = boilerplate $ do
|
toMarkup cp = boilerplate $ do
|
||||||
let sl = unSlug (slug (commentPageComment cp))
|
let sl = cp & commentPageComment & val & slug & unSlug
|
||||||
cid = commentPageUrl cp
|
cid = commentPageUrl cp
|
||||||
H.h2 $ do
|
H.h2 $ do
|
||||||
H.a ! A.href ("/comments/" <> cvt sl <> "#" <> cvt cid) $ H.text "Comment"
|
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
|
commentForm (url cp) "anonymous coward" Nothing
|
||||||
H.ul $ traverse_ (showChildren (comments cp) (viewTime cp)) (IxSet.toList roots)
|
H.ul $ traverse_ (showChildren (comments cp) (viewTime cp)) (IxSet.toList roots)
|
||||||
|
|
||||||
fromId :: Id -> UUID
|
|
||||||
fromId (Id x) = x
|
|
||||||
fromUserId :: UserId -> Text
|
fromUserId :: UserId -> Text
|
||||||
fromUserId (UserId x) = x
|
fromUserId (UserId x) = x
|
||||||
unSlug :: Slug -> Text
|
unSlug :: Slug -> Text
|
||||||
unSlug (Slug x) = x
|
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 =
|
commentForm slug user mparent =
|
||||||
H.form ! A.action "/comments" ! A.method "post" $ do
|
H.form ! A.action "/comments" ! A.method "post" $ do
|
||||||
H.input ! A.type_ "hidden" ! A.name "userid" ! A.value user
|
H.input ! A.type_ "hidden" ! A.name "userid" ! A.value user
|
||||||
|
@ -370,35 +290,95 @@ commentForm slug user mparent =
|
||||||
H.br
|
H.br
|
||||||
H.input ! A.type_ "submit" ! A.value "add comment"
|
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 $
|
showChildren cs vt comment = H.li $
|
||||||
displayComment comment vt $ do
|
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
|
if IxSet.null children
|
||||||
then return ()
|
then return ()
|
||||||
else H.ul $ traverse_ (showChildren cs vt) (IxSet.toList children)
|
else H.ul $ traverse_ (showChildren cs vt) (IxSet.toList children)
|
||||||
|
|
||||||
displayComment :: Comment -> UTCTime -> H.Markup -> H.Markup
|
displayComment :: Comment -> UTCTime -> H.Markup -> H.Markup
|
||||||
displayComment comment vt children = do
|
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.input ! A.type_ "checkbox" ! A.class_ "toggleinput" ! A.id (cvt inputid)
|
||||||
H.div $ do
|
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.div ! A.id (cvt cid) ! A.class_ "metas" $ do
|
||||||
H.label ! A.for (cvt inputid) ! A.class_ "togglelabel" $ H.span (H.text "[-]")
|
H.label ! A.for (cvt inputid) ! A.class_ "togglelabel" $ H.span (H.text "[-]")
|
||||||
H.a ! A.href (cvt ('#':cid)) $ "§ "
|
H.a ! A.href (cvt ('#':cid)) $ "§ "
|
||||||
H.text (fromUserId (userid comment))
|
H.text (fromUserId (userid (val comment)))
|
||||||
H.span ! A.class_ "time" $ do
|
H.span ! A.class_ "time" $ do
|
||||||
H.text " - "
|
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.text " ago"
|
||||||
H.div ! A.class_ "tohide" $ do
|
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"
|
H.a ! A.href (cvt ("/comment/" <> cid)) ! A.class_ "small" $ "reply"
|
||||||
children
|
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)
|
instance ToRow NewComment where toRow = SQL.genericToRow
|
||||||
initDB dbConf = Acid.openLocalStateFrom (filePath dbConf) initialComments
|
|
||||||
|
-- * 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
|
||||||
|
}
|
||||||
|
|
|
@ -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
|
module Aggreact.Css where
|
||||||
|
|
||||||
import Protolude hiding ((&), div)
|
import Protolude hiding ((&), div)
|
||||||
|
|
|
@ -1,11 +1,25 @@
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
|
||||||
{-# LANGUAGE Strict #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeSynonymInstances #-}
|
{-# 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
|
Module : Aggreact.Comments
|
||||||
Description : Example of a library file.
|
Description : Example of a library file.
|
||||||
|
@ -25,12 +39,24 @@ module Aggreact.Homepage
|
||||||
|
|
||||||
import Protolude
|
import Protolude
|
||||||
|
|
||||||
import Aggreact.Comments (Slug (..), boilerplate)
|
import Prelude (String)
|
||||||
|
import Aggreact.Comments (Slug (..))
|
||||||
|
import Aggreact.Html (boilerplate)
|
||||||
|
|
||||||
import Data.String (IsString (..))
|
import Data.String (IsString (..))
|
||||||
import qualified Text.Blaze.Html5 as H
|
import qualified Text.Blaze.Html5 as H
|
||||||
import qualified Text.Blaze.Html5.Attributes as A
|
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] }
|
newtype Homepage = Homepage { topSlugs :: [Slug] }
|
||||||
|
|
||||||
instance H.ToMarkup Homepage where
|
instance H.ToMarkup Homepage where
|
||||||
|
@ -39,4 +65,4 @@ instance H.ToMarkup Homepage where
|
||||||
H.h2 "Latest slugs"
|
H.h2 "Latest slugs"
|
||||||
H.ul $ traverse_ htmlSlug topSlugs
|
H.ul $ traverse_ htmlSlug topSlugs
|
||||||
where htmlSlug (Slug s) =
|
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
60
src/Aggreact/Html.hs
Normal 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
33
src/Aggreact/User.hs
Normal 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
117
src/Database/Store.hs
Normal 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
322
src/Database/Store/Backend/SQLite.hs
Normal 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
62
src/Database/Store/CRUD.hs
Normal 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
26
src/Database/Store/Search.hs
Normal 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)
|
|
@ -18,7 +18,7 @@ module DevelMain where
|
||||||
|
|
||||||
import Protolude
|
import Protolude
|
||||||
|
|
||||||
import Aggreact (Conf (..), initialize, shutdownApp)
|
import Aggreact (initialize, shutdownApp)
|
||||||
|
|
||||||
import Control.Concurrent (MVar, ThreadId, forkIO, killThread,
|
import Control.Concurrent (MVar, ThreadId, forkIO, killThread,
|
||||||
newEmptyMVar, putMVar, takeMVar)
|
newEmptyMVar, putMVar, takeMVar)
|
||||||
|
@ -31,6 +31,7 @@ import Foreign.Store (Store (..), lookupStore, readStore,
|
||||||
import GHC.Word (Word32)
|
import GHC.Word (Word32)
|
||||||
import Network.Wai.Handler.Warp (defaultSettings, runSettings,
|
import Network.Wai.Handler.Warp (defaultSettings, runSettings,
|
||||||
setPort)
|
setPort)
|
||||||
|
import Database.Store.Backend.SQLite (DBConf (SQLiteConf))
|
||||||
|
|
||||||
-- | Start or restart the server.
|
-- | Start or restart the server.
|
||||||
-- newStore is from foreign-store.
|
-- newStore is from foreign-store.
|
||||||
|
@ -63,9 +64,9 @@ update = do
|
||||||
start :: MVar () -- ^ Written to when the thread is killed.
|
start :: MVar () -- ^ Written to when the thread is killed.
|
||||||
-> IO ThreadId
|
-> IO ThreadId
|
||||||
start done = do
|
start done = do
|
||||||
(config, app) <- initialize
|
(commentHandler, app) <- initialize (SQLiteConf "aggreact.db" "comments")
|
||||||
forkIO (finally (runSettings (setPort (port config) defaultSettings) app)
|
forkIO (finally (runSettings (setPort 3000 defaultSettings) app)
|
||||||
(shutdownApp config >> putMVar done ()))
|
(shutdownApp commentHandler >> putMVar done ()))
|
||||||
|
|
||||||
-- | kill the server
|
-- | kill the server
|
||||||
shutdown :: IO ()
|
shutdown :: IO ()
|
||||||
|
|
58
src/Generics/SOP/Fieldnames.hs
Normal file
58
src/Generics/SOP/Fieldnames.hs
Normal 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"]
|
||||||
|
|
||||||
|
-}
|
|
@ -3,6 +3,22 @@
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE TypeSynonymInstances #-}
|
{-# 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
|
module Servant.Clay where
|
||||||
|
|
||||||
import Protolude hiding (encodeUtf8)
|
import Protolude hiding (encodeUtf8)
|
||||||
|
|
|
@ -18,7 +18,7 @@
|
||||||
#
|
#
|
||||||
# resolver: ./custom-snapshot.yaml
|
# resolver: ./custom-snapshot.yaml
|
||||||
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||||
resolver: lts-12.20
|
resolver: lts-13.0
|
||||||
|
|
||||||
# User packages to be built.
|
# User packages to be built.
|
||||||
# Various formats can be used as shown in the example below.
|
# Various formats can be used as shown in the example below.
|
||||||
|
@ -35,6 +35,7 @@ resolver: lts-12.20
|
||||||
# - wai
|
# - wai
|
||||||
packages:
|
packages:
|
||||||
- .
|
- .
|
||||||
|
# - '../sqlite-simple'
|
||||||
# Dependency packages to be pulled from upstream that are not in the resolver
|
# Dependency packages to be pulled from upstream that are not in the resolver
|
||||||
# using the same syntax as the packages field.
|
# using the same syntax as the packages field.
|
||||||
# (e.g., acme-missiles-0.3)
|
# (e.g., acme-missiles-0.3)
|
||||||
|
@ -43,7 +44,6 @@ extra-deps:
|
||||||
- syb-with-class-0.6.1.10
|
- syb-with-class-0.6.1.10
|
||||||
- acid-state-0.14.3
|
- acid-state-0.14.3
|
||||||
|
|
||||||
|
|
||||||
# Override default flag values for local packages and extra-deps
|
# Override default flag values for local packages and extra-deps
|
||||||
# flags: {}
|
# flags: {}
|
||||||
|
|
||||||
|
@ -67,3 +67,6 @@ extra-deps:
|
||||||
#
|
#
|
||||||
# Allow a newer minor version of GHC than the snapshot specifies
|
# Allow a newer minor version of GHC than the snapshot specifies
|
||||||
# compiler-check: newer-minor
|
# compiler-check: newer-minor
|
||||||
|
|
||||||
|
# for intero and 8.6.1
|
||||||
|
allow-newer: true
|
||||||
|
|
Loading…
Reference in a new issue