mirror of
https://github.com/aelve/guide.git
synced 2024-12-23 04:42:24 +03:00
Add get functions for categories, traits and items (#339)
This commit is contained in:
parent
9f8f0a2262
commit
36a92f9bf7
2
.gitignore
vendored
2
.gitignore
vendored
@ -22,6 +22,8 @@ cabal.config
|
|||||||
*.swp
|
*.swp
|
||||||
*.swo
|
*.swo
|
||||||
*#
|
*#
|
||||||
|
*.lock
|
||||||
|
|
||||||
|
|
||||||
# IDE/support
|
# IDE/support
|
||||||
.idea/
|
.idea/
|
||||||
|
@ -56,8 +56,12 @@ library
|
|||||||
Guide.Api.Error
|
Guide.Api.Error
|
||||||
Guide.Api.Utils
|
Guide.Api.Utils
|
||||||
Guide.Api.Guider
|
Guide.Api.Guider
|
||||||
Guide.Db
|
Guide.Database
|
||||||
Guide.Db.Schema
|
Guide.Database.Connection
|
||||||
|
Guide.Database.Convert
|
||||||
|
Guide.Database.Get
|
||||||
|
Guide.Database.Schema
|
||||||
|
Guide.Database.Types
|
||||||
Guide.Logger
|
Guide.Logger
|
||||||
Guide.Logger.Types
|
Guide.Logger.Types
|
||||||
Guide.Logger.Functions
|
Guide.Logger.Functions
|
||||||
@ -108,6 +112,7 @@ library
|
|||||||
, cmark-highlight == 0.2.*
|
, cmark-highlight == 0.2.*
|
||||||
, cmark-sections == 0.3.*
|
, cmark-sections == 0.3.*
|
||||||
, containers >= 0.5
|
, containers >= 0.5
|
||||||
|
, contravariant-extras
|
||||||
, data-default >= 0.5
|
, data-default >= 0.5
|
||||||
, deepseq >= 1.2.0.0
|
, deepseq >= 1.2.0.0
|
||||||
, df1
|
, df1
|
||||||
@ -129,6 +134,7 @@ library
|
|||||||
, hashable
|
, hashable
|
||||||
, haskell-src-meta
|
, haskell-src-meta
|
||||||
, hasql
|
, hasql
|
||||||
|
, hasql-transaction
|
||||||
, http-api-data
|
, http-api-data
|
||||||
, http-client
|
, http-client
|
||||||
, http-client-tls
|
, http-client-tls
|
||||||
@ -143,11 +149,13 @@ library
|
|||||||
, microlens-platform >= 0.3.2
|
, microlens-platform >= 0.3.2
|
||||||
, mmorph == 1.*
|
, mmorph == 1.*
|
||||||
, mtl >= 2.1.1
|
, mtl >= 2.1.1
|
||||||
|
, named
|
||||||
, neat-interpolation == 0.3.*
|
, neat-interpolation == 0.3.*
|
||||||
, network
|
, network
|
||||||
, network-uri
|
, network-uri
|
||||||
, patches-vector
|
, patches-vector
|
||||||
, random >= 1.1
|
, random >= 1.1
|
||||||
|
, raw-strings-qq
|
||||||
, reroute
|
, reroute
|
||||||
, safe
|
, safe
|
||||||
, safecopy
|
, safecopy
|
||||||
|
@ -199,8 +199,8 @@ createTrait itemId CCreateTrait{..} =
|
|||||||
throwError err400{errReasonPhrase = "'content' can not be empty"}
|
throwError err400{errReasonPhrase = "'content' can not be empty"}
|
||||||
traitId <- randomShortUid
|
traitId <- randomShortUid
|
||||||
addEdit . fst =<< case cctType of
|
addEdit . fst =<< case cctType of
|
||||||
Con -> dbUpdate (AddCon itemId traitId cctContent)
|
CCon -> dbUpdate (AddCon itemId traitId cctContent)
|
||||||
Pro -> dbUpdate (AddPro itemId traitId cctContent)
|
CPro -> dbUpdate (AddPro itemId traitId cctContent)
|
||||||
pure traitId
|
pure traitId
|
||||||
|
|
||||||
-- | Update the text of a trait (pro/con).
|
-- | Update the text of a trait (pro/con).
|
||||||
|
@ -308,17 +308,27 @@ type Api = RequestDetails :> ToServant Site AsApi
|
|||||||
--------------------------------------------------------------------------
|
--------------------------------------------------------------------------
|
||||||
|
|
||||||
-- | Trait type (Pro/Con) and instances.
|
-- | Trait type (Pro/Con) and instances.
|
||||||
data CTraitType = Pro | Con
|
data CTraitType = CPro | CCon
|
||||||
deriving (Show, Generic)
|
deriving (Show, Generic)
|
||||||
|
|
||||||
instance ToSchema CTraitType where
|
instance ToSchema CTraitType where
|
||||||
declareNamedSchema = genericDeclareNamedSchema schemaOptions
|
declareNamedSchema = genericDeclareNamedSchema schemaOptions
|
||||||
|
{ constructorTagModifier = \case
|
||||||
|
"CPro" -> "Pro"
|
||||||
|
"CCon" -> "Con"
|
||||||
|
other -> error ("CTraitType schema: unknown value " <> show other)
|
||||||
|
}
|
||||||
|
|
||||||
instance A.ToJSON CTraitType where
|
instance A.ToJSON CTraitType where
|
||||||
toJSON = A.genericToJSON jsonOptions
|
toJSON = \case
|
||||||
|
CPro -> "Pro"
|
||||||
|
CCon -> "Con"
|
||||||
|
|
||||||
instance A.FromJSON CTraitType where
|
instance A.FromJSON CTraitType where
|
||||||
parseJSON = A.genericParseJSON jsonOptions
|
parseJSON = A.withText "CTraitType" $ \case
|
||||||
|
"Pro" -> pure CPro
|
||||||
|
"Con" -> pure CCon
|
||||||
|
other -> fail ("unknown trait type " <> show other)
|
||||||
|
|
||||||
----------------------------------------------------------------------------
|
----------------------------------------------------------------------------
|
||||||
-- CDirection
|
-- CDirection
|
||||||
@ -333,7 +343,7 @@ instance ToSchema CDirection where
|
|||||||
{ constructorTagModifier = \case
|
{ constructorTagModifier = \case
|
||||||
"DirectionUp" -> "up"
|
"DirectionUp" -> "up"
|
||||||
"DirectionDown" -> "down"
|
"DirectionDown" -> "down"
|
||||||
other -> error ("Direction schema: unknown tag " <> show other)
|
other -> error ("CDirection schema: unknown value " <> show other)
|
||||||
}
|
}
|
||||||
|
|
||||||
instance A.ToJSON CDirection where
|
instance A.ToJSON CDirection where
|
||||||
@ -342,10 +352,10 @@ instance A.ToJSON CDirection where
|
|||||||
DirectionDown -> "down"
|
DirectionDown -> "down"
|
||||||
|
|
||||||
instance A.FromJSON CDirection where
|
instance A.FromJSON CDirection where
|
||||||
parseJSON = \case
|
parseJSON = A.withText "CDirection" $ \case
|
||||||
"up" -> pure DirectionUp
|
"up" -> pure DirectionUp
|
||||||
"down" -> pure DirectionDown
|
"down" -> pure DirectionDown
|
||||||
tag -> fail ("unknown direction " ++ show tag)
|
other -> fail ("unknown direction " <> show other)
|
||||||
|
|
||||||
----------------------------------------------------------------------------
|
----------------------------------------------------------------------------
|
||||||
-- CCreateItem
|
-- CCreateItem
|
||||||
|
9
back/src/Guide/Database.hs
Normal file
9
back/src/Guide/Database.hs
Normal file
@ -0,0 +1,9 @@
|
|||||||
|
module Guide.Database
|
||||||
|
(
|
||||||
|
module Guide.Database.Schema,
|
||||||
|
module Guide.Database.Get
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Guide.Database.Schema
|
||||||
|
import Guide.Database.Get
|
91
back/src/Guide/Database/Connection.hs
Normal file
91
back/src/Guide/Database/Connection.hs
Normal file
@ -0,0 +1,91 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
|
||||||
|
-- | Connect to the Guide database.
|
||||||
|
module Guide.Database.Connection
|
||||||
|
( connect
|
||||||
|
, runSessionExceptT
|
||||||
|
, runSession
|
||||||
|
, runTransactionExceptT
|
||||||
|
, runTransaction
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Imports
|
||||||
|
import Hasql.Connection (Connection, Settings)
|
||||||
|
import Hasql.Session (Session)
|
||||||
|
import Hasql.Transaction (Transaction)
|
||||||
|
import Hasql.Transaction.Sessions (Mode, IsolationLevel(..))
|
||||||
|
|
||||||
|
import qualified Hasql.Connection as HC
|
||||||
|
import qualified Hasql.Session as HS
|
||||||
|
import qualified Hasql.Transaction.Sessions as HT
|
||||||
|
|
||||||
|
import Guide.Database.Types (DatabaseError)
|
||||||
|
|
||||||
|
|
||||||
|
-- | Create a database connection (the destination is hard-coded for now).
|
||||||
|
--
|
||||||
|
-- Throws an 'error' if the connection could not be established.
|
||||||
|
connect :: IO Connection
|
||||||
|
connect = do
|
||||||
|
HC.acquire connectionSettings >>= \case
|
||||||
|
Left Nothing -> error "connect: unknown exception"
|
||||||
|
Left (Just x) -> error ("connect: " ++ toString x)
|
||||||
|
Right conn -> pure conn
|
||||||
|
|
||||||
|
-- | Connection settings
|
||||||
|
connectionSettings :: Settings
|
||||||
|
connectionSettings = HC.settings "localhost" 5432 dbUser dbPass dbName
|
||||||
|
|
||||||
|
-- | Database user
|
||||||
|
dbUser :: ByteString
|
||||||
|
dbUser = "postgres"
|
||||||
|
|
||||||
|
-- | Database password
|
||||||
|
dbPass :: ByteString
|
||||||
|
dbPass = "3"
|
||||||
|
|
||||||
|
-- | Database name
|
||||||
|
dbName :: ByteString
|
||||||
|
dbName = "guide"
|
||||||
|
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
-- Utilities
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Run an @ExceptT Session@ against the given database connection,
|
||||||
|
-- throwing an 'error' in case of failure.
|
||||||
|
runSessionExceptT :: Connection -> ExceptT DatabaseError Session a -> IO a
|
||||||
|
runSessionExceptT connection session =
|
||||||
|
unwrapRight =<< unwrapRight =<< HS.run (runExceptT session) connection
|
||||||
|
|
||||||
|
-- | Run a @Session@ against the given database connection, throwing an
|
||||||
|
-- 'error' in case of failure.
|
||||||
|
runSession :: Connection -> Session a -> IO a
|
||||||
|
runSession connection session =
|
||||||
|
unwrapRight =<< HS.run session connection
|
||||||
|
|
||||||
|
-- | Run an @ExceptT Transaction@ against the given database connection,
|
||||||
|
-- throwing an 'error' in case of failure.
|
||||||
|
--
|
||||||
|
-- The transaction is ran with the strongest ('Serializable') isolation
|
||||||
|
-- level. Use 'HT.transaction' if you need a different isolation level.
|
||||||
|
runTransactionExceptT
|
||||||
|
:: Connection -> Mode -> ExceptT DatabaseError Transaction a -> IO a
|
||||||
|
runTransactionExceptT connection mode transaction =
|
||||||
|
unwrapRight =<< unwrapRight =<<
|
||||||
|
HS.run (HT.transaction Serializable mode (runExceptT transaction)) connection
|
||||||
|
|
||||||
|
-- | Run a @Transaction@ against the given database connection, throwing an
|
||||||
|
-- 'error' in case of failure.
|
||||||
|
--
|
||||||
|
-- The transaction is ran with the strongest ('Serializable') isolation
|
||||||
|
-- level. Use 'HT.transaction' if you need a different isolation level.
|
||||||
|
runTransaction :: Connection -> Mode -> Transaction a -> IO a
|
||||||
|
runTransaction connection mode transaction =
|
||||||
|
unwrapRight =<<
|
||||||
|
HS.run (HT.transaction Serializable mode transaction) connection
|
||||||
|
|
||||||
|
-- | Unwrap 'Either', failing in case of 'Left'.
|
||||||
|
unwrapRight :: Show e => Either e a -> IO a
|
||||||
|
unwrapRight = either (error . show) pure
|
149
back/src/Guide/Database/Convert.hs
Normal file
149
back/src/Guide/Database/Convert.hs
Normal file
@ -0,0 +1,149 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
|
||||||
|
-- | Encoders and decoders for types used in the database schema.
|
||||||
|
module Guide.Database.Convert
|
||||||
|
(
|
||||||
|
-- * 'Bool'
|
||||||
|
boolParam
|
||||||
|
, boolParamNullable
|
||||||
|
|
||||||
|
-- * 'Text'
|
||||||
|
, textParam
|
||||||
|
, textParamNullable
|
||||||
|
, textColumn
|
||||||
|
, textColumnNullable
|
||||||
|
|
||||||
|
-- * 'Uid'
|
||||||
|
, uidParam
|
||||||
|
, uidColumn
|
||||||
|
|
||||||
|
-- * 'UTCTime'
|
||||||
|
, timestamptzColumn
|
||||||
|
|
||||||
|
-- * 'TraitType'
|
||||||
|
, traitTypeParam
|
||||||
|
|
||||||
|
-- * 'CategoryStatus'
|
||||||
|
, categoryStatusColumn
|
||||||
|
|
||||||
|
-- * @Set 'ItemSection'@
|
||||||
|
, itemSectionSetColumn
|
||||||
|
) where
|
||||||
|
|
||||||
|
|
||||||
|
import Imports
|
||||||
|
|
||||||
|
import Data.Functor.Contravariant (contramap)
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
|
import qualified Hasql.Decoders as HD
|
||||||
|
import qualified Hasql.Encoders as HE
|
||||||
|
|
||||||
|
import Guide.Types.Core (CategoryStatus (..), ItemSection (..), TraitType (..))
|
||||||
|
import Guide.Utils (Uid (..))
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
-- Bool
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Pass a 'Bool' to a query.
|
||||||
|
boolParam :: HE.Params Bool
|
||||||
|
boolParam = HE.param (HE.nonNullable HE.bool)
|
||||||
|
|
||||||
|
-- | Pass a nullable 'Bool' to a query.
|
||||||
|
boolParamNullable :: HE.Params (Maybe Bool)
|
||||||
|
boolParamNullable = HE.param (HE.nullable HE.bool)
|
||||||
|
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
-- Text
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Pass a 'Text' to a query.
|
||||||
|
textParam :: HE.Params Text
|
||||||
|
textParam = HE.param (HE.nonNullable HE.text)
|
||||||
|
|
||||||
|
-- | Pass a nullable 'Text' to a query.
|
||||||
|
textParamNullable :: HE.Params (Maybe Text)
|
||||||
|
textParamNullable = HE.param (HE.nullable HE.text)
|
||||||
|
|
||||||
|
-- | Get a 'Text' from a query.
|
||||||
|
textColumn :: HD.Row Text
|
||||||
|
textColumn = HD.column (HD.nonNullable HD.text)
|
||||||
|
|
||||||
|
-- | Get a nullable 'Text' from a query.
|
||||||
|
textColumnNullable :: HD.Row (Maybe Text)
|
||||||
|
textColumnNullable = HD.column (HD.nullable HD.text)
|
||||||
|
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
-- Uid
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Pass a 'Uid' to a query.
|
||||||
|
uidParam :: HE.Params (Uid a)
|
||||||
|
uidParam = contramap uidToText textParam
|
||||||
|
|
||||||
|
-- | Get a 'Uid' from a query.
|
||||||
|
uidColumn :: HD.Row (Uid a)
|
||||||
|
uidColumn = Uid <$> textColumn
|
||||||
|
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
-- UTCTime
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Get a 'UTCTime' from a query.
|
||||||
|
timestamptzColumn :: HD.Row UTCTime
|
||||||
|
timestamptzColumn = HD.column (HD.nonNullable HD.timestamptz)
|
||||||
|
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
-- TraitType
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Encode a 'TraitType'.
|
||||||
|
traitTypeEncoder :: HE.Value TraitType
|
||||||
|
traitTypeEncoder = HE.enum $ \case
|
||||||
|
Pro -> "pro"
|
||||||
|
Con -> "con"
|
||||||
|
|
||||||
|
-- | Pass a 'TraitType' to a query.
|
||||||
|
traitTypeParam :: HE.Params TraitType
|
||||||
|
traitTypeParam = HE.param (HE.nonNullable traitTypeEncoder)
|
||||||
|
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
-- CategoryStatus
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Decode a 'CategoryStatus'.
|
||||||
|
categoryStatusDecoder :: HD.Value CategoryStatus
|
||||||
|
categoryStatusDecoder = HD.enum $ \case
|
||||||
|
"stub" -> Just CategoryStub
|
||||||
|
"wip" -> Just CategoryWIP
|
||||||
|
"finished" -> Just CategoryFinished
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
-- | Get a 'CategoryStatus' from a query.
|
||||||
|
categoryStatusColumn :: HD.Row CategoryStatus
|
||||||
|
categoryStatusColumn = HD.column (HD.nonNullable categoryStatusDecoder)
|
||||||
|
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
-- Set ItemSection
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Decode an 'ItemSection'.
|
||||||
|
itemSectionDecoder :: HD.Value ItemSection
|
||||||
|
itemSectionDecoder = HD.enum $ \case
|
||||||
|
"pros_cons" -> Just ItemProsConsSection
|
||||||
|
"ecosystem" -> Just ItemEcosystemSection
|
||||||
|
"notes" -> Just ItemNotesSection
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
-- | Get a @Set ItemSection@ from a query.
|
||||||
|
itemSectionSetColumn :: HD.Row (Set ItemSection)
|
||||||
|
itemSectionSetColumn =
|
||||||
|
fmap Set.fromList
|
||||||
|
$ HD.column
|
||||||
|
$ HD.nonNullable
|
||||||
|
$ HD.listArray
|
||||||
|
$ HD.nonNullable
|
||||||
|
$ itemSectionDecoder
|
281
back/src/Guide/Database/Get.hs
Normal file
281
back/src/Guide/Database/Get.hs
Normal file
@ -0,0 +1,281 @@
|
|||||||
|
{-# LANGUAGE ApplicativeDo #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE OverloadedLabels #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
|
|
||||||
|
-- | Read-only database queries.
|
||||||
|
module Guide.Database.Get
|
||||||
|
(
|
||||||
|
-- * Trait
|
||||||
|
getTraitMaybe
|
||||||
|
, getTraitsByItem
|
||||||
|
-- * Item
|
||||||
|
, getItem
|
||||||
|
, getItemMaybe
|
||||||
|
, getItemsByCategory
|
||||||
|
-- * Category
|
||||||
|
, getCategory
|
||||||
|
, getCategoryMaybe
|
||||||
|
, getCategories
|
||||||
|
, getCategoryByItemMaybe
|
||||||
|
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Imports
|
||||||
|
|
||||||
|
import Contravariant.Extras.Contrazip (contrazip2, contrazip3)
|
||||||
|
import Hasql.Statement (Statement (..))
|
||||||
|
import Hasql.Transaction (Transaction)
|
||||||
|
import Hasql.Transaction.Sessions (Mode(Read))
|
||||||
|
import Named
|
||||||
|
import Text.RawString.QQ (r)
|
||||||
|
|
||||||
|
import qualified Data.Map as Map
|
||||||
|
import qualified Hasql.Decoders as HD
|
||||||
|
import qualified Hasql.Encoders as HE
|
||||||
|
import qualified Hasql.Transaction as HT
|
||||||
|
|
||||||
|
import Guide.Database.Connection (connect, runTransactionExceptT)
|
||||||
|
import Guide.Database.Convert
|
||||||
|
import Guide.Database.Types
|
||||||
|
import Guide.Markdown (toMarkdownBlock, toMarkdownInline, toMarkdownTree)
|
||||||
|
import Guide.Types.Core (Category (..), Item (..), Trait (..), TraitType (..))
|
||||||
|
import Guide.Utils (Uid (..))
|
||||||
|
|
||||||
|
|
||||||
|
-- | Just to test queries
|
||||||
|
getTest :: IO ()
|
||||||
|
getTest = do
|
||||||
|
conn <- connect
|
||||||
|
mTrait <- runTransactionExceptT conn Read (getTraitMaybe "qwertassdf34")
|
||||||
|
print mTrait
|
||||||
|
traits <- runTransactionExceptT conn Read $
|
||||||
|
getTraitsByItem "items1234567" (#deleted False) (#traitType Pro)
|
||||||
|
print traits
|
||||||
|
mItem <- runTransactionExceptT conn Read (getItemMaybe "items1234567")
|
||||||
|
print mItem
|
||||||
|
item <- runTransactionExceptT conn Read (getItem "items1234567")
|
||||||
|
print item
|
||||||
|
-- wrong uid
|
||||||
|
-- itemErr <- runTransactionExceptT conn Read (getItemByItemId "wrong1234567")
|
||||||
|
-- print itemErr
|
||||||
|
items <- runTransactionExceptT conn Read $
|
||||||
|
getItemsByCategory "categories11" (#deleted False)
|
||||||
|
print items
|
||||||
|
catM <- runTransactionExceptT conn Read (getCategoryMaybe "categories11")
|
||||||
|
print catM
|
||||||
|
cat <- runTransactionExceptT conn Read (getCategory "categories11")
|
||||||
|
print cat
|
||||||
|
mCatId <- runTransactionExceptT conn Read (getCategoryIdByItemMaybe "items1234567")
|
||||||
|
print mCatId
|
||||||
|
catIds <- runTransactionExceptT conn Read getCategoryIds
|
||||||
|
print catIds
|
||||||
|
cats <- runTransactionExceptT conn Read getCategories
|
||||||
|
print cats
|
||||||
|
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
-- Traits
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Get a 'Trait'.
|
||||||
|
--
|
||||||
|
-- Traits marked as deleted will still be returned if they physically exist
|
||||||
|
-- in the database.
|
||||||
|
getTraitMaybe :: Uid Trait -> ExceptT DatabaseError Transaction (Maybe Trait)
|
||||||
|
getTraitMaybe traitId = do
|
||||||
|
let sql = [r|
|
||||||
|
SELECT uid, content
|
||||||
|
FROM traits
|
||||||
|
WHERE uid = $1
|
||||||
|
|]
|
||||||
|
encoder = uidParam
|
||||||
|
decoder = HD.rowMaybe $ do
|
||||||
|
_traitUid <- uidColumn
|
||||||
|
_traitContent <- toMarkdownInline <$> textColumn
|
||||||
|
pure $ Trait{..}
|
||||||
|
lift $ HT.statement traitId (Statement sql encoder decoder False)
|
||||||
|
|
||||||
|
-- | Get traits belonging to an item.
|
||||||
|
--
|
||||||
|
-- The @#deleted@ flag specifies whether to return only "normal" or only
|
||||||
|
-- deleted traits. To get both, call 'getTraitsByItem' twice.
|
||||||
|
getTraitsByItem
|
||||||
|
:: Uid Item
|
||||||
|
-> "deleted" :! Bool
|
||||||
|
-> "traitType" :! TraitType
|
||||||
|
-> ExceptT DatabaseError Transaction [Trait]
|
||||||
|
getTraitsByItem itemId (arg #deleted -> deleted) (arg #traitType -> traitType) = do
|
||||||
|
let sql = [r|
|
||||||
|
SELECT uid, content
|
||||||
|
FROM traits
|
||||||
|
WHERE item_uid = $1
|
||||||
|
AND deleted = $2
|
||||||
|
AND type_ = ($3 :: trait_type)
|
||||||
|
|]
|
||||||
|
encoder = contrazip3 uidParam boolParam traitTypeParam
|
||||||
|
decoder = HD.rowList $ do
|
||||||
|
_traitUid <- uidColumn
|
||||||
|
_traitContent <- toMarkdownInline <$> textColumn
|
||||||
|
pure $ Trait{..}
|
||||||
|
lift $ HT.statement (itemId,deleted,traitType) (Statement sql encoder decoder False)
|
||||||
|
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
-- Items
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Get an 'Item'.
|
||||||
|
--
|
||||||
|
-- Items marked as deleted will still be returned if they physically exist
|
||||||
|
-- in the database.
|
||||||
|
getItemMaybe :: Uid Item -> ExceptT DatabaseError Transaction (Maybe Item)
|
||||||
|
getItemMaybe itemId = do
|
||||||
|
_itemPros <- getTraitsByItem itemId (#deleted False) (#traitType Pro)
|
||||||
|
_itemProsDeleted <- getTraitsByItem itemId (#deleted True) (#traitType Pro)
|
||||||
|
_itemCons <- getTraitsByItem itemId (#deleted False) (#traitType Con)
|
||||||
|
_itemConsDeleted <- getTraitsByItem itemId (#deleted True) (#traitType Con)
|
||||||
|
let prefix = "item-notes-" <> uidToText itemId <> "-"
|
||||||
|
let sql = [r|
|
||||||
|
SELECT uid, name, created, group_, link, hackage, summary, ecosystem, notes
|
||||||
|
FROM items
|
||||||
|
WHERE uid = $1
|
||||||
|
|]
|
||||||
|
encoder = uidParam
|
||||||
|
decoder = HD.rowMaybe $ do
|
||||||
|
_itemUid <- uidColumn
|
||||||
|
_itemName <- textColumn
|
||||||
|
_itemCreated <- timestamptzColumn
|
||||||
|
_itemGroup_ <- textColumnNullable
|
||||||
|
_itemLink <- textColumnNullable
|
||||||
|
_itemHackage <- textColumnNullable
|
||||||
|
_itemSummary <- toMarkdownBlock <$> textColumn
|
||||||
|
_itemEcosystem <- toMarkdownBlock <$> textColumn
|
||||||
|
_itemNotes <- toMarkdownTree prefix <$> textColumn
|
||||||
|
pure $ Item{..}
|
||||||
|
lift $ HT.statement itemId (Statement sql encoder decoder False)
|
||||||
|
|
||||||
|
-- | Get an 'Item'.
|
||||||
|
--
|
||||||
|
-- Items marked as deleted will still be returned if they physically exist
|
||||||
|
-- in the database.
|
||||||
|
--
|
||||||
|
-- Fails with 'ItemNotFound' when the item does not exist.
|
||||||
|
getItem :: Uid Item -> ExceptT DatabaseError Transaction Item
|
||||||
|
getItem itemId = do
|
||||||
|
mItem <- getItemMaybe itemId
|
||||||
|
case mItem of
|
||||||
|
Nothing -> throwError $ ItemNotFound itemId
|
||||||
|
Just item -> pure item
|
||||||
|
|
||||||
|
-- | Get items belonging to a category.
|
||||||
|
--
|
||||||
|
-- The @#deleted@ flag specifies whether to return only "normal" or only
|
||||||
|
-- deleted items. To get both, call 'getItemsByCategory' twice.
|
||||||
|
getItemsByCategory
|
||||||
|
:: Uid Category
|
||||||
|
-> "deleted" :! Bool
|
||||||
|
-> ExceptT DatabaseError Transaction [Item]
|
||||||
|
getItemsByCategory catId (arg #deleted -> deleted) = do
|
||||||
|
let sql = [r|
|
||||||
|
SELECT uid
|
||||||
|
FROM items
|
||||||
|
WHERE category_uid = $1
|
||||||
|
AND deleted = $2
|
||||||
|
|]
|
||||||
|
encoder = contrazip2 uidParam boolParam
|
||||||
|
decoder = HD.rowList $ uidColumn
|
||||||
|
itemUids <- lift $ HT.statement (catId,deleted) (Statement sql encoder decoder False)
|
||||||
|
traverse getItem itemUids
|
||||||
|
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
-- Categories
|
||||||
|
----------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | Get a 'Category'.
|
||||||
|
--
|
||||||
|
-- Categories marked as deleted will still be returned if they physically
|
||||||
|
-- exist in the database.
|
||||||
|
getCategoryMaybe :: Uid Category -> ExceptT DatabaseError Transaction (Maybe Category)
|
||||||
|
getCategoryMaybe catId = do
|
||||||
|
_categoryItems <- getItemsByCategory catId (#deleted False)
|
||||||
|
_categoryItemsDeleted <- getItemsByCategory catId (#deleted True)
|
||||||
|
let sql = [r|
|
||||||
|
SELECT uid, title, created, group_, status_, notes, enabled_sections
|
||||||
|
FROM categories
|
||||||
|
WHERE uid = $1
|
||||||
|
|]
|
||||||
|
encoder = uidParam
|
||||||
|
decoder = HD.rowMaybe $ do
|
||||||
|
_categoryUid <- uidColumn
|
||||||
|
_categoryTitle <- textColumn
|
||||||
|
_categoryCreated <- timestamptzColumn
|
||||||
|
_categoryGroup_ <- textColumn
|
||||||
|
_categoryStatus <- categoryStatusColumn
|
||||||
|
_categoryNotes <- toMarkdownBlock <$> textColumn
|
||||||
|
_categoryEnabledSections <- itemSectionSetColumn
|
||||||
|
let _categoryGroups = Map.empty -- TODO fix
|
||||||
|
pure $ Category{..}
|
||||||
|
lift $ HT.statement catId (Statement sql encoder decoder False)
|
||||||
|
|
||||||
|
-- | Get a 'Category'.
|
||||||
|
--
|
||||||
|
-- Categories marked as deleted will still be returned if they physically
|
||||||
|
-- exist in the database.
|
||||||
|
--
|
||||||
|
-- Fails with 'CategoryNotFound' when the category does not exist.
|
||||||
|
getCategory :: Uid Category -> ExceptT DatabaseError Transaction Category
|
||||||
|
getCategory catId = do
|
||||||
|
mCat <- getCategoryMaybe catId
|
||||||
|
case mCat of
|
||||||
|
Nothing -> throwError $ CategoryNotFound catId
|
||||||
|
Just cat -> pure cat
|
||||||
|
-- TODO: consider not returning deleted categories? Otherwise somebody
|
||||||
|
-- deletes a category but the page is still there.
|
||||||
|
|
||||||
|
-- | Get the ID of the category that an item belongs to.
|
||||||
|
getCategoryIdByItemMaybe
|
||||||
|
:: Uid Item -> ExceptT DatabaseError Transaction (Maybe (Uid Category))
|
||||||
|
getCategoryIdByItemMaybe itemId = do
|
||||||
|
let sql = [r|
|
||||||
|
SELECT category_uid
|
||||||
|
FROM items
|
||||||
|
WHERE uid = $1
|
||||||
|
|]
|
||||||
|
encoder = uidParam
|
||||||
|
decoder = HD.rowMaybe $ uidColumn
|
||||||
|
lift $ HT.statement itemId (Statement sql encoder decoder False)
|
||||||
|
|
||||||
|
-- | Get the category that an item belongs to.
|
||||||
|
--
|
||||||
|
-- Returns 'Nothing' if either the item or the category are not found.
|
||||||
|
getCategoryByItemMaybe
|
||||||
|
:: Uid Item -> ExceptT DatabaseError Transaction (Maybe Category)
|
||||||
|
getCategoryByItemMaybe itemId = do
|
||||||
|
catId <- getCategoryIdByItemMaybe itemId
|
||||||
|
join @Maybe <$> traverse getCategoryMaybe catId
|
||||||
|
|
||||||
|
-- | Get a list of available categories' IDs.
|
||||||
|
--
|
||||||
|
-- Includes categories marked as deleted.
|
||||||
|
--
|
||||||
|
-- TODO explain why we store deleted categories at all.
|
||||||
|
getCategoryIds :: ExceptT DatabaseError Transaction [Uid Category]
|
||||||
|
getCategoryIds = do
|
||||||
|
let sql = [r|
|
||||||
|
SELECT uid
|
||||||
|
FROM categories
|
||||||
|
|]
|
||||||
|
encoder = HE.noParams
|
||||||
|
decoder = HD.rowList $ uidColumn
|
||||||
|
lift $ HT.statement () (Statement sql encoder decoder False)
|
||||||
|
|
||||||
|
-- | Get all categories.
|
||||||
|
--
|
||||||
|
-- Includes categories marked as deleted.
|
||||||
|
getCategories :: ExceptT DatabaseError Transaction [Category]
|
||||||
|
getCategories = do
|
||||||
|
catIds <- getCategoryIds
|
||||||
|
traverse getCategory catIds
|
@ -2,7 +2,8 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
|
||||||
|
|
||||||
module Guide.Db.Schema
|
-- | Schemas to create table for guide database
|
||||||
|
module Guide.Database.Schema
|
||||||
(
|
(
|
||||||
setupDatabase,
|
setupDatabase,
|
||||||
)
|
)
|
||||||
@ -11,15 +12,15 @@ where
|
|||||||
import Imports
|
import Imports
|
||||||
|
|
||||||
import Hasql.Session (Session)
|
import Hasql.Session (Session)
|
||||||
import NeatInterpolation
|
import Text.RawString.QQ
|
||||||
import Hasql.Connection (Connection, Settings)
|
|
||||||
import Hasql.Statement (Statement (..))
|
import Hasql.Statement (Statement (..))
|
||||||
|
|
||||||
import qualified Hasql.Session as HS
|
import qualified Hasql.Session as HS
|
||||||
import qualified Hasql.Connection as HC
|
|
||||||
import qualified Hasql.Encoders as HE
|
import qualified Hasql.Encoders as HE
|
||||||
import qualified Hasql.Decoders as HD
|
import qualified Hasql.Decoders as HD
|
||||||
|
|
||||||
|
import Guide.Database.Connection (connect, runSession)
|
||||||
|
|
||||||
|
|
||||||
-- | List of all migrations.
|
-- | List of all migrations.
|
||||||
migrations :: [(Int32, Session ())]
|
migrations :: [(Int32, Session ())]
|
||||||
@ -41,7 +42,7 @@ migrations =
|
|||||||
setupDatabase :: IO ()
|
setupDatabase :: IO ()
|
||||||
setupDatabase = do
|
setupDatabase = do
|
||||||
conn <- connect
|
conn <- connect
|
||||||
mbSchemaVersion <- run' getSchemaVersion conn
|
mbSchemaVersion <- runSession conn getSchemaVersion
|
||||||
case mbSchemaVersion of
|
case mbSchemaVersion of
|
||||||
Nothing -> formatLn "No schema found. Creating tables and running all migrations."
|
Nothing -> formatLn "No schema found. Creating tables and running all migrations."
|
||||||
Just v -> formatLn "Schema version is {}." v
|
Just v -> formatLn "Schema version is {}." v
|
||||||
@ -49,43 +50,9 @@ setupDatabase = do
|
|||||||
for_ migrations $ \(migrationVersion, migration) ->
|
for_ migrations $ \(migrationVersion, migration) ->
|
||||||
when (migrationVersion > schemaVersion) $ do
|
when (migrationVersion > schemaVersion) $ do
|
||||||
format "Migration {}: " migrationVersion
|
format "Migration {}: " migrationVersion
|
||||||
run' (migration >> setSchemaVersion migrationVersion) conn
|
runSession conn (migration >> setSchemaVersion migrationVersion)
|
||||||
formatLn "done."
|
formatLn "done."
|
||||||
|
|
||||||
-- | Create a database connection (the destination is hard-coded for now).
|
|
||||||
--
|
|
||||||
-- Throws an 'error' if the connection could not be established.
|
|
||||||
connect :: IO Connection
|
|
||||||
connect = do
|
|
||||||
HC.acquire connectionSettings >>= \case
|
|
||||||
Left Nothing -> error "connect: unknown exception"
|
|
||||||
Left (Just x) -> error ("connect: " ++ toString x)
|
|
||||||
Right conn -> pure conn
|
|
||||||
|
|
||||||
-- | Connection settings
|
|
||||||
connectionSettings :: Settings
|
|
||||||
connectionSettings = HC.settings "localhost" 5432 dbUser dbPass dbName
|
|
||||||
|
|
||||||
-- | Database user
|
|
||||||
dbUser :: ByteString
|
|
||||||
dbUser = "postgres"
|
|
||||||
|
|
||||||
-- | Database password
|
|
||||||
dbPass :: ByteString
|
|
||||||
dbPass = "3"
|
|
||||||
|
|
||||||
-- | Database name
|
|
||||||
dbName :: ByteString
|
|
||||||
dbName = "guide"
|
|
||||||
|
|
||||||
----------------------------------------------------------------------------
|
|
||||||
-- Utilities
|
|
||||||
----------------------------------------------------------------------------
|
|
||||||
|
|
||||||
-- | Like 'HS.run', but errors out in case of failure.
|
|
||||||
run' :: Session a -> Connection -> IO a
|
|
||||||
run' s c = either (error . show) pure =<< HS.run s c
|
|
||||||
|
|
||||||
----------------------------------------------------------------------------
|
----------------------------------------------------------------------------
|
||||||
-- Schema version table
|
-- Schema version table
|
||||||
----------------------------------------------------------------------------
|
----------------------------------------------------------------------------
|
||||||
@ -96,7 +63,7 @@ run' s c = either (error . show) pure =<< HS.run s c
|
|||||||
-- If the @schema_version@ table doesn't exist, creates it.
|
-- If the @schema_version@ table doesn't exist, creates it.
|
||||||
getSchemaVersion :: Session (Maybe Int32)
|
getSchemaVersion :: Session (Maybe Int32)
|
||||||
getSchemaVersion = do
|
getSchemaVersion = do
|
||||||
HS.sql $ toByteString [text|
|
HS.sql [r|
|
||||||
CREATE TABLE IF NOT EXISTS schema_version (
|
CREATE TABLE IF NOT EXISTS schema_version (
|
||||||
name text PRIMARY KEY,
|
name text PRIMARY KEY,
|
||||||
version integer
|
version integer
|
||||||
@ -136,17 +103,17 @@ v0 = do
|
|||||||
|
|
||||||
-- | Create an enum type for trait type ("pro" or "con").
|
-- | Create an enum type for trait type ("pro" or "con").
|
||||||
v0_createTypeProCon :: Session ()
|
v0_createTypeProCon :: Session ()
|
||||||
v0_createTypeProCon = HS.sql $ toByteString [text|
|
v0_createTypeProCon = HS.sql [r|
|
||||||
CREATE TYPE trait_type AS ENUM ('pro', 'con');
|
CREATE TYPE trait_type AS ENUM ('pro', 'con');
|
||||||
|]
|
|]
|
||||||
|
|
||||||
-- | Create table @traits@, corresponding to 'Guide.Types.Core.Trait'.
|
-- | Create table @traits@, corresponding to 'Guide.Types.Core.Trait'.
|
||||||
v0_createTableTraits :: Session ()
|
v0_createTableTraits :: Session ()
|
||||||
v0_createTableTraits = HS.sql $ toByteString [text|
|
v0_createTableTraits = HS.sql [r|
|
||||||
CREATE TABLE traits (
|
CREATE TABLE traits (
|
||||||
uid text PRIMARY KEY, -- Unique trait ID
|
uid text PRIMARY KEY, -- Unique trait ID
|
||||||
content text NOT NULL, -- Trait content as Markdown
|
content text NOT NULL, -- Trait content as Markdown
|
||||||
deleted boolean -- Whether the trait is deleted
|
deleted boolean -- Whether the trait is deleted
|
||||||
DEFAULT false
|
DEFAULT false
|
||||||
NOT NULL,
|
NOT NULL,
|
||||||
type_ trait_type NOT NULL, -- Trait type (pro or con)
|
type_ trait_type NOT NULL, -- Trait type (pro or con)
|
||||||
@ -158,11 +125,11 @@ v0_createTableTraits = HS.sql $ toByteString [text|
|
|||||||
|
|
||||||
-- | Create table @items@, corresponding to 'Guide.Types.Core.Item'.
|
-- | Create table @items@, corresponding to 'Guide.Types.Core.Item'.
|
||||||
v0_createTableItems :: Session ()
|
v0_createTableItems :: Session ()
|
||||||
v0_createTableItems = HS.sql $ toByteString [text|
|
v0_createTableItems = HS.sql [r|
|
||||||
CREATE TABLE items (
|
CREATE TABLE items (
|
||||||
uid text PRIMARY KEY, -- Unique item ID
|
uid text PRIMARY KEY, -- Unique item ID
|
||||||
name text NOT NULL, -- Item title
|
name text NOT NULL, -- Item title
|
||||||
created timestamp NOT NULL, -- When the item was created
|
created timestamptz NOT NULL, -- When the item was created
|
||||||
group_ text, -- Optional group
|
group_ text, -- Optional group
|
||||||
link text, -- Optional URL
|
link text, -- Optional URL
|
||||||
hackage text, -- Package name on Hackage
|
hackage text, -- Package name on Hackage
|
||||||
@ -180,11 +147,11 @@ v0_createTableItems = HS.sql $ toByteString [text|
|
|||||||
|
|
||||||
-- | Create table @categories@, corresponding to 'Guide.Types.Core.Category'.
|
-- | Create table @categories@, corresponding to 'Guide.Types.Core.Category'.
|
||||||
v0_createTableCategories :: Session ()
|
v0_createTableCategories :: Session ()
|
||||||
v0_createTableCategories = HS.sql $ toByteString [text|
|
v0_createTableCategories = HS.sql [r|
|
||||||
CREATE TABLE categories (
|
CREATE TABLE categories (
|
||||||
uid text PRIMARY KEY, -- Unique category ID
|
uid text PRIMARY KEY, -- Unique category ID
|
||||||
title text NOT NULL, -- Category title
|
title text NOT NULL, -- Category title
|
||||||
created timestamp NOT NULL, -- When the category was created
|
created timestamptz NOT NULL, -- When the category was created
|
||||||
group_ text NOT NULL, -- "Grandcategory"
|
group_ text NOT NULL, -- "Grandcategory"
|
||||||
status_ text NOT NULL, -- Category status ("in progress", etc); the list of
|
status_ text NOT NULL, -- Category status ("in progress", etc); the list of
|
||||||
-- possible statuses is defined by backend
|
-- possible statuses is defined by backend
|
||||||
@ -196,7 +163,7 @@ v0_createTableCategories = HS.sql $ toByteString [text|
|
|||||||
|
|
||||||
-- | Create table @users@, storing user data.
|
-- | Create table @users@, storing user data.
|
||||||
v0_createTableUsers :: Session ()
|
v0_createTableUsers :: Session ()
|
||||||
v0_createTableUsers = HS.sql $ toByteString [text|
|
v0_createTableUsers = HS.sql [r|
|
||||||
CREATE TABLE users (
|
CREATE TABLE users (
|
||||||
uid text PRIMARY KEY, -- Unique user ID
|
uid text PRIMARY KEY, -- Unique user ID
|
||||||
name text NOT NULL, -- User name
|
name text NOT NULL, -- User name
|
||||||
@ -211,11 +178,11 @@ v0_createTableUsers = HS.sql $ toByteString [text|
|
|||||||
-- | Create table @pending_edits@, storing users' edits and metadata about
|
-- | Create table @pending_edits@, storing users' edits and metadata about
|
||||||
-- them (who made the edit, when, etc).
|
-- them (who made the edit, when, etc).
|
||||||
v0_createTablePendingEdits :: Session ()
|
v0_createTablePendingEdits :: Session ()
|
||||||
v0_createTablePendingEdits = HS.sql $ toByteString [text|
|
v0_createTablePendingEdits = HS.sql [r|
|
||||||
CREATE TABLE pending_edits (
|
CREATE TABLE pending_edits (
|
||||||
uid bigserial PRIMARY KEY, -- Unique id
|
uid bigserial PRIMARY KEY, -- Unique id
|
||||||
edit json NOT NULL, -- Edit in JSON format
|
edit json NOT NULL, -- Edit in JSON format
|
||||||
ip inet, -- IP address of edit maker
|
ip inet, -- IP address of edit maker
|
||||||
time_ timestamp NOT NULL -- When the edit was created
|
time_ timestamptz NOT NULL -- When the edit was created
|
||||||
);
|
);
|
||||||
|]
|
|]
|
17
back/src/Guide/Database/Types.hs
Normal file
17
back/src/Guide/Database/Types.hs
Normal file
@ -0,0 +1,17 @@
|
|||||||
|
-- | Types for postgres database
|
||||||
|
module Guide.Database.Types
|
||||||
|
(
|
||||||
|
DatabaseError(..)
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Imports
|
||||||
|
|
||||||
|
import Guide.Types.Core (Category (..), Item (..))
|
||||||
|
import Guide.Utils (Uid (..))
|
||||||
|
|
||||||
|
|
||||||
|
-- | Custom datatype errors for database
|
||||||
|
data DatabaseError
|
||||||
|
= ItemNotFound (Uid Item)
|
||||||
|
| CategoryNotFound (Uid Category)
|
||||||
|
deriving Show
|
@ -1,7 +0,0 @@
|
|||||||
module Guide.Db
|
|
||||||
(
|
|
||||||
module Guide.Db.Schema
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
import Guide.Db.Schema
|
|
@ -1,7 +1,6 @@
|
|||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
@ -28,8 +27,6 @@ import Control.Concurrent.Async
|
|||||||
import Safe (headDef)
|
import Safe (headDef)
|
||||||
-- Monads and monad transformers
|
-- Monads and monad transformers
|
||||||
import Control.Monad.Morph
|
import Control.Monad.Morph
|
||||||
-- Text
|
|
||||||
import NeatInterpolation (text)
|
|
||||||
-- Web
|
-- Web
|
||||||
import Lucid hiding (for_)
|
import Lucid hiding (for_)
|
||||||
import Network.Wai.Middleware.Static (addBase, staticPolicy)
|
import Network.Wai.Middleware.Static (addBase, staticPolicy)
|
||||||
@ -261,9 +258,9 @@ guideApp waiMetrics = do
|
|||||||
Spock.get "/js.js" $ do
|
Spock.get "/js.js" $ do
|
||||||
setHeader "Content-Type" "application/javascript; charset=utf-8"
|
setHeader "Content-Type" "application/javascript; charset=utf-8"
|
||||||
(csrfTokenName, csrfTokenValue) <- getCsrfHeader
|
(csrfTokenName, csrfTokenValue) <- getCsrfHeader
|
||||||
let jqueryCsrfProtection = [text|
|
let jqueryCsrfProtection =
|
||||||
guidejs.csrfProtection.enable("$csrfTokenName", "$csrfTokenValue");
|
format "guidejs.csrfProtection.enable(\"{}\", \"{}\");"
|
||||||
|]
|
csrfTokenName csrfTokenValue
|
||||||
js <- getJS
|
js <- getJS
|
||||||
Spock.bytes $ toByteString (fromJS allJSFunctions <> js <> jqueryCsrfProtection)
|
Spock.bytes $ toByteString (fromJS allJSFunctions <> js <> jqueryCsrfProtection)
|
||||||
-- CSS
|
-- CSS
|
||||||
|
@ -19,6 +19,7 @@
|
|||||||
module Guide.Types.Core
|
module Guide.Types.Core
|
||||||
(
|
(
|
||||||
Trait(..),
|
Trait(..),
|
||||||
|
TraitType (..),
|
||||||
ItemKind(..),
|
ItemKind(..),
|
||||||
hackageName,
|
hackageName,
|
||||||
ItemSection(..),
|
ItemSection(..),
|
||||||
@ -102,6 +103,10 @@ instance A.ToJSON Trait where
|
|||||||
toJSON = A.genericToJSON A.defaultOptions {
|
toJSON = A.genericToJSON A.defaultOptions {
|
||||||
A.fieldLabelModifier = over _head toLower . drop (T.length "_trait") }
|
A.fieldLabelModifier = over _head toLower . drop (T.length "_trait") }
|
||||||
|
|
||||||
|
-- | ADT for traitType
|
||||||
|
data TraitType = Pro | Con
|
||||||
|
deriving Eq
|
||||||
|
|
||||||
----------------------------------------------------------------------------
|
----------------------------------------------------------------------------
|
||||||
-- Item
|
-- Item
|
||||||
----------------------------------------------------------------------------
|
----------------------------------------------------------------------------
|
||||||
|
@ -30,7 +30,7 @@ where
|
|||||||
import Imports
|
import Imports
|
||||||
|
|
||||||
import Lucid hiding (for_)
|
import Lucid hiding (for_)
|
||||||
import NeatInterpolation
|
import Text.RawString.QQ (r)
|
||||||
|
|
||||||
import Guide.Config
|
import Guide.Config
|
||||||
import Guide.JS (JS (..))
|
import Guide.JS (JS (..))
|
||||||
@ -131,7 +131,7 @@ headTagDef page = do
|
|||||||
unless (T.null googleToken) $
|
unless (T.null googleToken) $
|
||||||
meta_ [name_ "google-site-verification", content_ googleToken]
|
meta_ [name_ "google-site-verification", content_ googleToken]
|
||||||
-- Report all Javascript errors with alerts
|
-- Report all Javascript errors with alerts
|
||||||
script_ [text|
|
script_ [r|
|
||||||
window.onerror = function (msg, url, lineNo, columnNo, error) {
|
window.onerror = function (msg, url, lineNo, columnNo, error) {
|
||||||
alert("Error in "+url+" at "+lineNo+":"+columnNo+": "+msg+
|
alert("Error in "+url+" at "+lineNo+":"+columnNo+": "+msg+
|
||||||
"\n\n"+
|
"\n\n"+
|
||||||
@ -145,10 +145,10 @@ headTagDef page = do
|
|||||||
onPageLoad (JS "autosize($('textarea'));")
|
onPageLoad (JS "autosize($('textarea'));")
|
||||||
-- CSS that makes 'shown' and 'noScriptShown' work;
|
-- CSS that makes 'shown' and 'noScriptShown' work;
|
||||||
-- see Note [show-hide]
|
-- see Note [show-hide]
|
||||||
noscript_ $ style_ [text|
|
noscript_ $ style_ [r|
|
||||||
.section:not(.noscript-shown) {display:none;}
|
.section:not(.noscript-shown) {display:none;}
|
||||||
|]
|
|]
|
||||||
script_ [text|
|
script_ [r|
|
||||||
var sheet = document.createElement('style');
|
var sheet = document.createElement('style');
|
||||||
sheet.innerHTML = '.section:not(.shown) {display:none;}';
|
sheet.innerHTML = '.section:not(.shown) {display:none;}';
|
||||||
// “head” instead of “body” because body isn't loaded yet
|
// “head” instead of “body” because body isn't loaded yet
|
||||||
|
@ -64,7 +64,6 @@ import Web.Spock.Config
|
|||||||
import Data.List.Split
|
import Data.List.Split
|
||||||
-- digestive-functors
|
-- digestive-functors
|
||||||
import Text.Digestive (View)
|
import Text.Digestive (View)
|
||||||
-- import NeatInterpolation
|
|
||||||
-- Web
|
-- Web
|
||||||
import Lucid hiding (for_)
|
import Lucid hiding (for_)
|
||||||
import Lucid.Base (makeAttribute)
|
import Lucid.Base (makeAttribute)
|
||||||
|
@ -21,6 +21,7 @@ extra-deps:
|
|||||||
- lzma-clib-5.2.2
|
- lzma-clib-5.2.2
|
||||||
- regex-1.0.1.5
|
- regex-1.0.1.5
|
||||||
- hasql-1.4
|
- hasql-1.4
|
||||||
|
- hasql-transaction-0.7.2
|
||||||
|
|
||||||
# Old versions from LTS 12+ (can and should be upgraded)
|
# Old versions from LTS 12+ (can and should be upgraded)
|
||||||
- megaparsec-6.5.0
|
- megaparsec-6.5.0
|
||||||
|
Loading…
Reference in New Issue
Block a user