bimap-server (empty) → 0.1.0.0
raw patch · 4 files changed
+234/−0 lines, 4 filesdep +aesondep +basedep +bimapsetup-changed
Dependencies added: aeson, base, bimap, binary, directory, http-types, unix, wai, warp
Files
- Data/Bimap/Server.hs +175/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- bimap-server.cabal +27/−0
+ Data/Bimap/Server.hs view
@@ -0,0 +1,175 @@++{-# 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
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Daniel Díaz++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Daniel Díaz nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bimap-server.cabal view
@@ -0,0 +1,27 @@+name: bimap-server+version: 0.1.0.0+synopsis: Two-column database server.+description: A server that stores a database with two columns, where the elements in each column are of the same type.+ Operations are fast, although memory usage increases with the number of rows. The implementation is based+ in bimaps.+license: BSD3+license-file: LICENSE+author: Daniel Díaz+maintainer: dhelta.diaz@gmail.com+category: Data+build-type: Simple+cabal-version: >=1.10++library+ exposed-modules: Data.Bimap.Server+ other-extensions: OverloadedStrings, ScopedTypeVariables+ build-depends: base == 4.*+ , binary+ , bimap+ , wai+ , warp+ , http-types+ , aeson >= 0.9+ , unix+ , directory+ default-language: Haskell2010