diff --git a/guide.cabal b/guide.cabal index a4a3809..7150c24 100644 --- a/guide.cabal +++ b/guide.cabal @@ -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 diff --git a/src/Guide/Api.hs b/src/Guide/Api.hs new file mode 100644 index 0000000..e92a885 --- /dev/null +++ b/src/Guide/Api.hs @@ -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 diff --git a/src/Guide/Main.hs b/src/Guide/Main.hs index 0fda2a0..2a33dc5 100644 --- a/src/Guide/Main.hs +++ b/src/Guide/Main.hs @@ -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 @@ -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 -- - 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 diff --git a/src/Guide/ServerStuff.hs b/src/Guide/ServerStuff.hs index 7a6e59c..9f61c03 100644 --- a/src/Guide/ServerStuff.hs +++ b/src/Guide/ServerStuff.hs @@ -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 diff --git a/src/Guide/State.hs b/src/Guide/State.hs index 1ac8288..d607fd9 100644 --- a/src/Guide/State.hs +++ b/src/Guide/State.hs @@ -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 diff --git a/src/Imports.hs b/src/Imports.hs index d9c66fc..1d3bd29 100644 --- a/src/Imports.hs +++ b/src/Imports.hs @@ -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) diff --git a/stack.yaml b/stack.yaml index d942061..145dfaf 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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