diff --git a/IPv6DB.cabal b/IPv6DB.cabal --- a/IPv6DB.cabal +++ b/IPv6DB.cabal @@ -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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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