aelve/guide
1
1
Fork 0
mirror of https://github.com/aelve/guide.git synced 2024-11-24 05:45:11 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #198 from aelve/neongreen/api

Browse Source 
Implement a very simple Servant API
This commit is contained in:
Artyom Kazak 2017-09-01 12:45:20 +03:00 committed by GitHub
commit b364f2fe6c
7 changed files with 210 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
guide.cabal
View File

@ -45,6 +45,7 @@ executable guide
library
exposed-modules:
Guide.App
Guide.Api
Guide.Main
Guide.ServerStuff
Guide.Session
@ -131,7 +132,10 @@ library
, safe
, safecopy
, safecopy-migrate
, say
, scrypt
, servant-generic
, servant-server
, shortcut-links >= 0.4.2
, slave-thread
, split
@ -150,6 +154,7 @@ library
, wai
, wai-middleware-metrics
, wai-middleware-static
, warp
, xml
, xss-sanitize
ghc-options: -Wall -fno-warn-unused-do-bind

106
src/Guide/Api.hs Normal file
View File

@ -0,0 +1,106 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
module Guide.Api
(
Site(..),
runApiServer,
)
where
import Imports
import Data.Aeson
import Servant
import Servant.Generic
import Network.Wai.Handler.Warp (run)
import Data.Acid as Acid
-- putStrLn that works well with concurrency
import Say (say)
import Guide.Types
import Guide.State
import Guide.Utils (Uid)
----------------------------------------------------------------------------
-- Routes
----------------------------------------------------------------------------
-- | The description of the served API.
data Site route = Site
{
-- | A list of all categories (the /haskell page). Returns category
-- titles.
_getCategories :: route :-
"categories" :> Get '[JSON] [CategoryInfo]
-- | Details of a single category (and items in it, etc)
, _getCategory :: route :-
"category" :> Capture "id" (Uid Category)
:> Get '[JSON] (Either ApiError Category)
}
deriving (Generic)
data ApiError = ApiError !Text
deriving (Generic)
instance FromJSON ApiError
instance ToJSON ApiError
----------------------------------------------------------------------------
-- Boilerplate
----------------------------------------------------------------------------
apiServer :: DB -> Site AsServer
apiServer db = Site {
_getCategories = getCategories db,
_getCategory = getCategory db
}
type Api = ToServant (Site AsApi)
-- | Serve the API on port 4400.
--
-- You can test this API by doing @withDB mempty runApiServer@.
runApiServer :: AcidState GlobalState -> IO ()
runApiServer db = do
say "API is running on port 4400"
run 4400 $ serve (Proxy @Api) (toServant (apiServer db))
----------------------------------------------------------------------------
-- Implementations of methods
----------------------------------------------------------------------------
data CategoryInfo = CategoryInfo {
_categoryInfoUid :: Uid Category,
_categoryInfoTitle :: Text,
_categoryInfoCreated :: UTCTime,
_categoryInfoGroup_ :: Text,
_categoryInfoStatus :: CategoryStatus
}
deriving (Show, Generic)
instance ToJSON CategoryInfo
getCategories :: DB -> Handler [CategoryInfo]
getCategories db = do
liftIO (Acid.query db GetCategories) <&> \xs ->
map categoryToInfo xs
where
categoryToInfo Category{..} = CategoryInfo {
_categoryInfoUid = _categoryUid,
_categoryInfoTitle = _categoryTitle,
_categoryInfoCreated = _categoryCreated,
_categoryInfoGroup_ = _categoryGroup_,
_categoryInfoStatus = _categoryStatus }
getCategory :: DB -> Uid Category -> Handler (Either ApiError Category)
getCategory db catId =
liftIO (Acid.query db (GetCategoryMaybe catId)) <&> \case
Nothing -> Left (ApiError "category not found")
Just cat -> Right cat

53
src/Guide/Main.hs
View File

@ -22,8 +22,6 @@ where
import Imports
-- Containers
import qualified Data.Map as M
-- ByteString
import qualified Data.ByteString as BS
-- Lists
@ -59,10 +57,13 @@ import qualified SlaveThread as Slave
import System.Posix.Signals
-- Watching the templates directory
import qualified System.FSNotify as FSNotify
-- putStrLn that works well with concurrency
import Say (say)
-- HVect
import Data.HVect hiding (length)
import Guide.App
import Guide.Api
import Guide.ServerStuff
import Guide.Handlers
import Guide.Config
@ -146,20 +147,11 @@ mainWith config = do
-- won't be visible
emptyCache
startTemplateWatcher
let emptyState = GlobalState {
_categories = [],
_categoriesDeleted = [],
_actions = [],
_pendingEdits = [],
_editIdCounter = 0,
_sessionStore = M.empty,
_users = M.empty,
_dirty = True }
do args <- getArgs
let option = headDef "" args
when (option == "--dry-run") $ do
db :: DB <- openLocalStateFrom "state/" (error "couldn't load state")
putStrLn "loaded the database successfully"
say "loaded the database successfully"
closeAcidState db
exitSuccess
-- USAGE: --load-public <filename>
@ -174,25 +166,22 @@ mainWith config = do
db <- openLocalStateFrom "state/" emptyState
Acid.update db (ImportPublicDB publicDB)
createCheckpointAndClose' db
putStrLn "PublicDB imported to GlobalState"
say "PublicDB imported to GlobalState"
exitSuccess
-- When we run in GHCi and we exit the main thread, the EKG thread (that
-- runs the localhost:5050 server which provides statistics) may keep
-- running. This makes running this in GHCi annoying, because you have to
-- restart GHCi before every run. So, we kill the thread in the finaliser.
ekgId <- newIORef Nothing
-- See Note [acid-state] for the explanation of 'openLocalStateFrom',
-- 'createCheckpoint', etc
let prepare = openLocalStateFrom "state/" emptyState
finalise db = do
putStrLn "Creating an acid-state checkpoint and closing acid-state"
createCheckpointAndClose' db
workFinished <- newEmptyMVar
let finishWork = do
-- Killing EKG has to be done last, because of
-- <https://github.com/tibbe/ekg/issues/62>
putStrLn "Killing EKG"
say "Killing EKG"
mapM_ killThread =<< readIORef ekgId
bracket prepare finalise $ \db -> do
installTerminationCatcher =<< myThreadId
putMVar workFinished ()
installTerminationCatcher =<< myThreadId
workThread <- Slave.fork $ withDB finishWork $ \db -> do
hSetBuffering stdout NoBuffering
-- Create a checkpoint every six hours. Note: if nothing was changed, the
-- checkpoint won't be created, which saves us some space.
@ -200,7 +189,9 @@ mainWith config = do
createCheckpoint' db
threadDelay (1000000 * 3600 * 6)
-- EKG metrics
ekg <- EKG.forkServer "localhost" 5050
ekg <- do
say "EKG is running on port 5050"
EKG.forkServer "localhost" 5050
writeIORef ekgId (Just (EKG.serverThreadId ekg))
waiMetrics <- EKG.registerWaiMetrics (EKG.serverMetricStore ekg)
categoryGauge <- EKG.getGauge "db.categories" ekg
@ -212,7 +203,8 @@ mainWith config = do
EKG.Gauge.set categoryGauge (fromIntegral (length allCategories))
EKG.Gauge.set itemGauge (fromIntegral (length allItems))
threadDelay (1000000 * 60)
-- Create an admin user
-- Run the API
Slave.fork $ runApiServer db
-- Run the server
let serverState = ServerState {
_config = config,
@ -235,7 +227,10 @@ mainWith config = do
spc_csrfProtection = True,
spc_sessionCfg = sessionCfg }
when (_prerender config) $ prerenderPages config db
runSpock 8080 $ spock spockConfig $ guideApp waiMetrics
say "Spock is running on port 8080"
runSpockNoBanner 8080 $ spock spockConfig $ guideApp waiMetrics
forever (threadDelay (1000000 * 60))
`finally` (killThread workThread >> takeMVar workFinished)
-- TODO: Fix indentation after rebasing.
guideApp :: EKG.WaiMetrics -> GuideApp ()
@ -454,11 +449,13 @@ data Quit = CtrlC | ServiceStop
instance Exception Quit
{- | Set up a handler that would catch SIGINT (i.e. Ctrl-C) and SIGTERM
(i.e. service stop) and throw an exception instead of them. This lets us
{- | Set up a handler that would catch SIGINT (i.e. Ctrl-C) and SIGTERM (i.e.
service stop) and throw an exception instead of the signal. This lets us
create a checkpoint and close connections on exit.
-}
installTerminationCatcher :: ThreadId -> IO ()
installTerminationCatcher
:: ThreadId -- ^ Thread to kill when the signal comes
-> IO ()
installTerminationCatcher thread = void $ do
installHandler sigINT (CatchOnce (throwTo thread CtrlC)) Nothing
installHandler sigTERM (CatchOnce (throwTo thread ServiceStop)) Nothing

38
src/Guide/ServerStuff.hs
View File

@ -13,9 +13,8 @@ module Guide.ServerStuff
(
ServerState(..),
getConfig,
DB,
dbUpdate,
dbQuery,
dbUpdate,
dbQuery,
-- * Cache
uncache,
@ -30,10 +29,6 @@ module Guide.ServerStuff
itemVar,
categoryVar,
traitVar,
-- * Other helpers
createCheckpoint',
createCheckpointAndClose',
)
where
@ -46,7 +41,6 @@ import qualified Web.Spock as Spock
import Web.Routing.Combinators (PathState(..))
-- acid-state
import Data.Acid as Acid
import Data.Acid.Local as Acid
import Guide.Config
import Guide.State
@ -67,10 +61,6 @@ getConfig :: (Monad m, HasSpock m, SpockState m ~ ServerState)
=> m Config
getConfig = _config <$> Spock.getState
-- | A pointer to an open acid-state database (allows making queries/updates,
-- creating checkpoints, etc).
type DB = AcidState GlobalState
-- | Update something in the database. Don't forget to 'invalidateCache' or
-- use 'uncache' when you update something that is cached.
--
@ -319,27 +309,3 @@ categoryVar = "category" <//> var
-- | A path pieces for traits
traitVar :: Path '[Uid Trait] 'Open
traitVar = "trait" <//> var
----------------------------------------------------------------------------
-- Other helpers
----------------------------------------------------------------------------
-- | Like 'createCheckpoint', but doesn't create a checkpoint if there were
-- no changes made.
createCheckpoint' :: MonadIO m => DB -> m ()
createCheckpoint' db = liftIO $ do
wasDirty <- Acid.update db UnsetDirty
when wasDirty $ do
createArchive db
createCheckpoint db
-- | Like 'createCheckpointAndClose', but doesn't create a checkpoint if
-- there were no changes made.
createCheckpointAndClose' :: MonadIO m => DB -> m ()
createCheckpointAndClose' db = liftIO $ do
wasDirty <- Acid.update db UnsetDirty
if wasDirty then do
createArchive db
createCheckpointAndClose db
else do
closeAcidState db

68
src/Guide/State.hs
View File

@ -13,6 +13,12 @@ Site's database, and methods for manipulating it.
-}
module Guide.State
(
DB,
withDB,
createCheckpoint',
createCheckpointAndClose',
-- * type of global state
GlobalState(..),
categories,
categoriesDeleted,
@ -20,6 +26,7 @@ module Guide.State
pendingEdits,
editIdCounter,
findCategoryByItem,
emptyState,
-- * acid-state methods
-- ** query
@ -108,6 +115,7 @@ import Data.IP
import Data.SafeCopy hiding (kind)
import Data.SafeCopy.Migrate
import Data.Acid as Acid
import Data.Acid.Local as Acid
--
import Web.Spock.Internal.SessionManager (SessionId)
@ -184,6 +192,22 @@ Guide.hs
-}
----------------------------------------------------------------------------
-- GlobalState
----------------------------------------------------------------------------
emptyState :: GlobalState
emptyState = GlobalState {
_categories = [],
_categoriesDeleted = [],
_actions = [],
_pendingEdits = [],
_editIdCounter = 0,
_sessionStore = M.empty,
_users = M.empty,
_dirty = True }
data GlobalState = GlobalState {
_categories :: [Category],
_categoriesDeleted :: [Category],
@ -891,3 +915,47 @@ makeAcidic ''GlobalState [
'importPublicDB,
'exportPublicDB
]
----------------------------------------------------------------------------
-- DB helpers (have to be at the end of the file)
----------------------------------------------------------------------------
-- | A connection to an open acid-state database (allows making
-- queries/updates, creating checkpoints, etc).
type DB = AcidState GlobalState
-- | Open the database, do something with it, then close the database.
--
-- See Note [acid-state] for the explanation of 'openLocalStateFrom',
-- 'createCheckpoint', etc.
withDB
:: IO () -- ^ Action to run after closing the database
-> (DB -> IO ()) -- ^ Action to run when the database is open
-> IO ()
withDB afterClose action = do
let prepare = openLocalStateFrom "state/" emptyState
finalise db = do
putStrLn "Creating an acid-state checkpoint and closing acid-state"
createCheckpointAndClose' db
afterClose
bracket prepare finalise action
-- | Like 'createCheckpoint', but doesn't create a checkpoint if there were
-- no changes made.
createCheckpoint' :: MonadIO m => DB -> m ()
createCheckpoint' db = liftIO $ do
wasDirty <- Acid.update db UnsetDirty
when wasDirty $ do
createArchive db
createCheckpoint db
-- | Like 'createCheckpointAndClose', but doesn't create a checkpoint if
-- there were no changes made.
createCheckpointAndClose' :: MonadIO m => DB -> m ()
createCheckpointAndClose' db = liftIO $ do
wasDirty <- Acid.update db UnsetDirty
if wasDirty then do
createArchive db
createCheckpointAndClose db
else do
closeAcidState db

4
src/Imports.hs
View File

@ -13,7 +13,8 @@ module Imports
where
import BasePrelude as X hiding (Category, GeneralCategory, lazy, (&))
import BasePrelude as X
hiding (Category, GeneralCategory, lazy, (&), Handler)
-- Lists
import Data.List.Extra as X (dropEnd, takeEnd)
import Data.List.Index as X
@ -23,6 +24,7 @@ import Lens.Micro.Platform as X
import Control.Monad.IO.Class as X
import Control.Monad.Reader as X
import Control.Monad.State as X
import Control.Monad.Except as X
-- Common types
import Data.ByteString as X (ByteString)
import Data.Map as X (Map)

1
stack.yaml
View File

@ -18,3 +18,4 @@ extra-deps:
- fmt-0.4.0.0
- Spock-digestive-0.3.0.0
- digestive-functors-0.8.2.0
- servant-generic-0.1.0.0