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, killThread)
import Control.Monad (when, forever)
import System.Posix.Signals
( installHandler
, Handler (CatchOnce)
, softwareTermination
)
import System.Directory (doesFileExist)
bimapServer :: forall a b .
( Binary a, Binary b
, FromJSON a, FromJSON b
, ToJSON a, ToJSON b
, Ord a, Ord b
)
=> Proxy a
-> Proxy b
-> Int
-> Int
-> IO ()
bimapServer _ _ p saveTime = do
let settings = setPort p
. setServerName "bimap-server"
v <- newMVar (BM.empty :: Bimap a b)
sv <- newMVar ()
fv <- newEmptyMVar
let saveFile = "saved.bimap"
exst <- doesFileExist saveFile
when exst $ modifyMVar_ v $ const $ BM.fromList <$> decodeFile saveFile
_ <- forkIO $ forever $ do
threadDelay $ saveTime * 1000 * 1000
takeMVar sv
readMVar v >>= encodeFile saveFile . BM.toList
putMVar sv ()
let app req respr =
case (requestMethod req, pathInfo req) of
("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"
("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"
("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"
("GET",["list"]) -> (>>=respr) $ responseLBS ok200 [] . encode . BM.toList <$> readMVar v
("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"
("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"
_ -> respr $ responseLBS notFound404 [] "The requested route does not exist, or you are using the wrong method.\n"
th <- forkIO $ runSettings (settings defaultSettings) app
_ <- installHandler softwareTermination (CatchOnce $ putMVar fv ()) Nothing
takeMVar fv
takeMVar sv
readMVar v >>= encodeFile saveFile . BM.toList
killThread th