IPv6DB 0.2.6 → 0.3.0
raw patch · 2 files changed
+66/−95 lines, 2 filesdep ~IPv6Addr
Dependency ranges changed: IPv6Addr
Files
- IPv6DB.cabal +4/−4
- app/Main.hs +62/−91
IPv6DB.cabal view
@@ -1,6 +1,6 @@ name: IPv6DB-version: 0.2.6-synopsis: A RESTful Web Service for IPv6-related data+version: 0.3.0+synopsis: A RESTful microService for IPv6-related data description: IPv6DB is a RESTful microservice using Redis as backend to store lists of IPv6 addresses and attach to each of them any valuable data in a schema-free valid JSON value.@@ -28,7 +28,7 @@ , attoparsec >= 0.13.1.0 && < 0.14 , base >= 4.8.2 && < 5.0 , bytestring >= 0.10.6 && < 0.11- , IPv6Addr >= 1.0.0 && < 1.1.0+ , IPv6Addr >= 1.1.0 && < 1.2.0 , hedis >= 0.9.4 && < 0.11 , http-types >= 0.9.1 && < 0.13 , unordered-containers >= 0.2.7.2 && < 0.2.10@@ -47,7 +47,7 @@ , base >= 4.8.2 && < 5.0 , bytestring >= 0.10.6 && < 0.11 , fast-logger >= 2.4.8 && < 2.5- , IPv6Addr >= 1.0.0 && < 1.1.0+ , IPv6Addr >= 1.1.0 && < 1.2.0 , IPv6DB , hedis >= 0.9.4 && < 0.11 , http-types >= 0.9.1 && < 0.13
app/Main.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader@@ -80,49 +82,42 @@ env@Env{..} <- ask liftIO $ case mtd of - mtd' | mtd' == PUT || mtd' == POST -> do- mjson <- maybeJSONBody- case mjson of- Just (Resources rsrcs) -> do- results <- mapM (setSource redisConn mtd') rsrcs- if all (== RedisOk) results- then noContent204- else jsonRes400 (encode results)- Nothing -> badJSONRequest+ mtd' | mtd' == PUT || mtd' == POST ->+ maybeJSONBody >>= maybe badJSONRequest answer+ where+ answer (Resources rsrcs) = do+ results <- mapM (setSource redisConn mtd') rsrcs+ if all (== RedisOk) results+ then noContent204+ else jsonRes400 (encode results) - GET -> do- mjson <- maybeJSONBody- case mjson of- Just ents -> do- msrcs <- runRedis redisConn (getByEntries ents)- case msrcs of- Right srcs ->- withEnv env (fromEntries ents srcs) >>= jsonOk- Left _ -> jsonError "Backend Error"- Nothing -> badJSONRequest+ GET -> maybeJSONBody >>= maybe badJSONRequest answer+ where+ answer ents =+ runRedis redisConn (getByEntries ents) >>= \case+ Right srcs -> withEnv env (fromEntries ents srcs) >>= jsonOk+ Left _ -> jsonError "Backend Error" - DELETE -> do- mjson <- maybeJSONBody- case mjson of- Just ents -> do- ed <- runRedis redisConn (delByEntries ents)- case ed of- Right d ->- case d of- 0 -> jsonRes404 (justError "No Deletion Performed")- _ -> noContent204- Left _ -> jsonError "Backend Error"- Nothing -> badJSONRequest+ DELETE -> maybeJSONBody >>= maybe badJSONRequest answer+ where+ answer ents = do+ runRedis redisConn (delByEntries ents) >>= \case+ Right d ->+ case d of+ 0 -> jsonRes404 (justError "No Deletion Performed")+ _ -> noContent204+ Left _ -> jsonError "Backend Error"+ _ -> methodNotAllowed listHandler mtd list = do env@Env{..} <- ask liftIO $ case mtd of - mtd' | mtd' == PUT || mtd' == POST -> do- mjson <- maybeJSONBody- case mjson of- Just (Array v) -> do+ mtd' | mtd' == PUT || mtd' == POST ->+ maybeJSONBody >>= maybe badJSONRequest answer+ where+ answer (Array v) = do let rsrcs = (\o -> maybeResource o [("list",String list)]) <$> V.toList v if Nothing `notElem` rsrcs@@ -132,55 +127,47 @@ then noContent204 else jsonRes400 (encode $ filter (/= RedisOk) results) else badJSONRequest- _ -> badJSONRequest - GET -> do- mjson <- maybeJSONBody- case mjson of- Just addrs -> do- emsrcs <- runRedis redisConn (getByAddresses list addrs)- case emsrcs of- Right msrcs ->- withEnv env (fromAddresses list addrs msrcs) >>= jsonOk- Left _ -> jsonServerError "Backend Error"- Nothing -> badJSONRequest+ GET -> maybeJSONBody >>= maybe badJSONRequest answer+ where+ answer addrs =+ runRedis redisConn (getByAddresses list addrs) >>= \case+ Right msrcs ->+ withEnv env (fromAddresses list addrs msrcs) >>= jsonOk+ Left _ -> jsonServerError "Backend Error" - DELETE -> do- mjson <- maybeJSONBody- case mjson of- Just addrs -> do- ed <- runRedis redisConn (delByAddresses list addrs)- case ed of+ DELETE ->+ maybeJSONBody >>= maybe badJSONRequest answer+ where+ answer addrs =+ runRedis redisConn (delByAddresses list addrs) >>= \case Right d -> case d of 0 -> jsonRes404 (justError "Resource To Delete Not Found") _ -> noContent204 Left _ -> jsonServerError "Backend Error"- Nothing -> badJSONRequest+ _ -> methodNotAllowed listAddressHandler mtd list addr = do Env{..} <- ask liftIO $ case mtd of - mtd' | mtd' == PUT || mtd' == POST -> do- mjson <- maybeJSONBody- case mjson of- Just o ->+ mtd' | mtd' == PUT || mtd' == POST ->+ maybeJSONBody >>= maybe badJSONRequest answer+ where+ answer o = case maybeResource o [("list", String list),("address", String addr)] of- Just rsrc -> do- rdres <- setSource redisConn mtd' rsrc- case rdres of+ Just rsrc ->+ setSource redisConn mtd' rsrc >>= \case RedisOk -> noContent204 error -> jsonRes400 (encode error) Nothing -> jsonRes400 (justError "Bad JSON Request")- Nothing -> badJSONRequest GET -> case maybeIPv6Addr addr of- Just (IPv6Addr addr') -> do- emsrc <- liftIO (runRedis redisConn $ getSource list addr')- case emsrc of+ Just (IPv6Addr addr') ->+ liftIO (runRedis redisConn $ getSource list addr') >>= \case Right msrc -> case msrc of Just src -> do@@ -200,9 +187,8 @@ DELETE -> case maybeIPv6Addr addr of- Just (IPv6Addr addr') -> do- er <- liftIO (runRedis redisConn $ delSource list addr')- case er of+ Just (IPv6Addr addr') ->+ liftIO (runRedis redisConn $ delSource list addr') >>= \case Right i -> case i of 1 -> noContent204@@ -215,43 +201,28 @@ "The Resource Doesn't Exist" Left _ -> jsonError "Backend Error" Nothing -> jsonError "Not an IPv6 Address in URI"+ _ -> methodNotAllowed -- -------------------------------------------------------------------- -- -- JSON Responses -- -- -------------------------------------------------------------------- -- - jsonOk bs = do- logWith status200- res (jsonRes status200 bs)+ jsonOk bs = logWith status200 >> res (jsonRes status200 bs) - noContent204 = do- logWith status204- res (responseLBS status204 [] BSL.empty)+ noContent204 = logWith status204 >> res (responseLBS status204 [] BSL.empty) - jsonRes400 bs = do- logWith status400- res (jsonRes status400 bs)+ jsonRes400 bs = logWith status400 >> res (jsonRes status400 bs) - badJSONRequest = do- logWith status400- jsonError "Bad JSON Request"+ badJSONRequest = logWith status400 >> jsonError "Bad JSON Request" - jsonError err = do- logWith status400- res (jsonRes status400 $ justError err)+ jsonError err = logWith status400 >> res (jsonRes status400 $ justError err) - jsonRes404 bs = do- logWith status404- res (jsonRes status404 bs)+ jsonRes404 bs = logWith status404 >> res (jsonRes status404 bs) - methodNotAllowed = do- logWith status405- res (jsonRes status405 $ justError "Method Not Allowed")+ methodNotAllowed = logWith status405 >> res (jsonRes status405 $ justError "Method Not Allowed") - jsonServerError err = do- logWith status500- res (jsonRes status500 $ justError err)+ jsonServerError err = logWith status500 >> res (jsonRes status500 $ justError err) jsonRes status = responseLBS