bimap-server-0.1.0.0: Data/Bimap/Server.hs
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
-- | A bimap server is basically a server that stores a one-to-one correspondence between
-- two sets of values. You can think of it as a table with two columns, where each column
-- has elements of the same type. You can lookup the table and update it using JSON based
-- HTTP requests.
--
-- This is how you run the server:
--
-- > bimapServer (Proxy :: Proxy Int) -- This proxy specifies the type of the values in the left column
-- > (Proxy :: Proxy String) -- This proxy specifies the type of the values in the right column
-- > 5000 -- Server will be running in port 5000
-- > 60 -- This is the number of seconds between saves
--
-- In this example, the server will save in the file @"saved.bimap"@ the table every 60 seconds.
-- Keep in mind that 'bimapServer' will install a handle for SIGTERM signals, meaning that a 'kill' signal
-- will be catched by the process, triggering a save of the table. After saving the table, the server will
-- stop running. However, the port that the server was using may still not be available until the program
-- using 'bimapServer' is closed.
--
-- The interface of the server is as follows:
--
-- * [GET] @/list@: Returns the list of rows in the table. The format is @[[a1,b1],...,[aN,bN]]@. You can use
-- the aeson's encoding of the type @[(a,b)]@ for decoding it.
--
-- * [GET] @/left-lookup@: Lookup an element in the table by searching in the left column. It returns the element
-- in the right column (if any) in JSON format as described by the 'ToJSON' instance. The
-- element to lookup is specified using its JSON encoded form as the body of the HTTP request.
-- * [GET] @/right-lookup@: Just as @/left-lookup@, except that using the right column for searching, and returning
-- the element in the left column (if any).
--
-- * [POST] @/insert@: Insert a pair of values in the table, replacing any occurences. The pair is sent in the body
-- of the HTTP request, in JSON format, using the aeson's encoding of pairs (tuples of size 2).
--
-- * [DELETE] @/left-delete@: Delete a row by searching in the left column. The value to look for in the left column
-- is passed JSON-encoded as the body of the HTTP request.
--
-- * [DELETE] @/right-delete@: Just as @/left-delete@, but searching in the right column.
--
module Data.Bimap.Server (
bimapServer
, Proxy (..)
) where
import Data.Bimap (Bimap)
import qualified Data.Bimap as BM
import Data.Proxy
import Network.Wai.Handler.Warp
( runSettings
, defaultSettings
, setPort
, setServerName
)
import Network.Wai
( responseLBS
, strictRequestBody
, pathInfo
, requestMethod
)
import Network.HTTP.Types
( ok200
, badRequest400
, notFound404
)
import Control.Concurrent.MVar
import Data.Aeson
( eitherDecode
, encode
, ToJSON
, FromJSON
)
import Data.Binary (Binary, encodeFile, decodeFile)
import Data.String (fromString)
import Control.Concurrent (forkIO, threadDelay)
import Control.Monad (when, forever)
import System.Posix.Signals
( installHandler
, Handler (CatchOnce)
, softwareTermination
)
import System.Directory (doesFileExist)
-- | Function to start a bimap server. The 'Binary' instances are used
-- for saving the table to file. 'FromJSON' and 'ToJSON' instances are
-- used for the HTTP interface. The 'Ord' instances are used to implement
-- fast lookups.
bimapServer :: forall a b .
( Binary a, Binary b
, FromJSON a, FromJSON b
, ToJSON a, ToJSON b
, Ord a, Ord b
)
=> Proxy a -- ^ Type of left keys
-> Proxy b -- ^ Type of right keys
-> Int -- ^ Port to run the server
-> Int -- ^ Number of seconds between saves
-> IO ()
bimapServer _ _ p saveTime = do
let settings = setPort p
. setServerName "bimap-server"
-- Bimap variable
v <- newMVar (BM.empty :: Bimap a b)
-- Semaphore variable
sv <- newMVar ()
-- Final handle variable
fv <- newEmptyMVar
-- Load file
let saveFile = "saved.bimap"
exst <- doesFileExist saveFile
when exst $ modifyMVar_ v $ const $ BM.fromList <$> decodeFile saveFile
-- Periodic file saving
_ <- forkIO $ forever $ do
threadDelay $ saveTime * 1000 * 1000
takeMVar sv
readMVar v >>= encodeFile saveFile . BM.toList
putMVar sv ()
--
let app req respr =
-- Response builder
case (requestMethod req, pathInfo req) of
-- Left lookup
("GET",["left-lookup"]) -> do
ek <- eitherDecode <$> strictRequestBody req
case ek of
Left err -> respr $ responseLBS badRequest400 [] $ fromString $ "Malformed or missing JSON: " ++ err ++ "\n"
Right k -> do
bm <- readMVar v
respr $ case BM.lookup k bm of
Just x -> responseLBS ok200 [] $ encode x
_ -> responseLBS notFound404 [] "Requested left key not found.\n"
-- Right lookup
("GET",["right-lookup"]) -> do
ek <- eitherDecode <$> strictRequestBody req
case ek of
Left err -> respr $ responseLBS badRequest400 [] $ fromString $ "Malformed or missing JSON: " ++ err ++ "\n"
Right k -> do
bm <- readMVar v
respr $ case BM.lookupR k bm of
Just x -> responseLBS ok200 [] $ encode x
_ -> responseLBS notFound404 [] "Requested right key not found.\n"
-- Insert
("POST",["insert"]) -> do
ep <- eitherDecode <$> strictRequestBody req
case ep of
Left err -> respr $ responseLBS badRequest400 [] $ fromString $ "Malformed input: " ++ err ++ "\n"
Right (l,r) -> do
modifyMVar_ v $ return . BM.insert l r
respr $ responseLBS ok200 [] "Row inserted.\n"
-- List
("GET",["list"]) -> (>>=respr) $ responseLBS ok200 [] . encode . BM.toList <$> readMVar v
-- Left delete
("DELETE",["left-delete"]) -> do
ek <- eitherDecode <$> strictRequestBody req
case ek of
Left err -> respr $ responseLBS badRequest400 [] $ fromString $ "Malformed or missing JSON: " ++ err ++ "\n"
Right k -> do
modifyMVar_ v $ return . BM.delete k
respr $ responseLBS ok200 [] "Row deleted.\n"
-- Right delete
("DELETE",["right-delete"]) -> do
ek <- eitherDecode <$> strictRequestBody req
case ek of
Left err -> respr $ responseLBS badRequest400 [] $ fromString $ "Malformed or missing JSON: " ++ err ++ "\n"
Right k -> do
modifyMVar_ v $ return . BM.deleteR k
respr $ responseLBS ok200 [] "Row deleted.\n"
-- 404
_ -> respr $ responseLBS notFound404 [] "The requested route does not exist, or you are using the wrong method.\n"
--
_ <- forkIO $ runSettings (settings defaultSettings) app
_ <- installHandler softwareTermination (CatchOnce $ putMVar fv ()) Nothing
takeMVar fv
takeMVar sv -- Semaphore is set permanently in red
readMVar v >>= encodeFile saveFile . BM.toList