IPv6DB (empty) → 0.1.0
raw patch · 11 files changed
+1356/−0 lines, 11 filesdep +IPv6Addrdep +IPv6DBdep +aesonsetup-changed
Dependencies added: IPv6Addr, IPv6DB, aeson, attoparsec, base, bytestring, fast-logger, hedis, hspec, http-client, http-types, mtl, optparse-applicative, text, unordered-containers, vector, wai, wai-logger, warp
Files
- IPv6DB.cabal +83/−0
- IPv6DB_APIv1.md +225/−0
- LICENSE +28/−0
- README.md +46/−0
- Setup.hs +2/−0
- app/Main.hs +259/−0
- app/Options.hs +70/−0
- app/Queries.hs +218/−0
- app/Types.hs +41/−0
- src/Network/IPv6DB/Types.hs +117/−0
- tests/hspec.hs +267/−0
+ IPv6DB.cabal view
@@ -0,0 +1,83 @@+name: IPv6DB+version: 0.1.0+cabal-version: >=1.10+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: (c) 2017 - Michel Boucey+maintainer: michel.boucey@cybervisible.fr+homepage: https://github.com/MichelBoucey/IPv6DB+synopsis: A RESTful Web Service 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.+ Each resource can be permanent or TTLed.+category: network, database+author: Michel Boucey+extra-source-files:+ README.md+ IPv6DB_APIv1.md++source-repository head+ type: git+ location: https://github.com/MichelBoucey/IPv6DB.git++library+ exposed-modules:+ Network.IPv6DB.Types+ build-depends:+ aeson >=0.11.2 && <1.2,+ attoparsec >=0.13.1.0 && <0.14,+ base >=4.9.0 && <5.0,+ bytestring >=0.10.6 && <0.11,+ IPv6Addr >=1.0.0 && <1.1.0,+ hedis >=0.9.4 && <0.10,+ http-types >=0.9.1 && <0.10,+ unordered-containers >=0.2.7.2 && <0.2.9,+ mtl >=2.2.1 && <2.3,+ text >=1.2.2 && <1.3,+ vector >=0.11.0.0 && <0.13+ default-language: Haskell2010+ hs-source-dirs: src++executable ipv6db+ main-is: Main.hs+ build-depends:+ aeson >=0.11.2 && <1.2,+ base >=4.9.0 && <5.0,+ bytestring >=0.10.6 && <0.11,+ fast-logger >=2.4.8 && <2.5,+ IPv6Addr >=1.0.0 && <1.1.0,+ IPv6DB >=0.1.0 && <0.2,+ hedis >=0.9.4 && <0.10,+ http-types >=0.9.1 && <0.10,+ unordered-containers >=0.2.7.2 && <0.2.9,+ mtl >=2.2.1 && <2.3,+ optparse-applicative >=0.12.1.0 && <0.14,+ text >=1.2.2 && <1.3,+ vector >=0.11.0.0 && <0.13,+ wai >=3.2.1 && <3.3,+ wai-logger >=2.3.0 && <2.4,+ warp >=3.2.9 && <3.3+ default-language: Haskell2010+ hs-source-dirs: app+ other-modules:+ Options+ Queries+ Types+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall++test-suite tests+ type: exitcode-stdio-1.0+ main-is: hspec.hs+ build-depends:+ aeson >=0.11.2 && <1.2,+ hspec >=2.1.10 && <2.5,+ base >=4.8 && <5,+ IPv6DB >=0.1.0 && <0.2,+ vector >=0.11.0.0 && <0.13,+ http-client >=0.4.31.2 && <0.5,+ http-types >=0.9.1 && <0.10+ default-language: Haskell2010+ hs-source-dirs: tests
+ IPv6DB_APIv1.md view
@@ -0,0 +1,225 @@+# IPv6DB APIv1++## A RESTful Web service for IPv6-related data++- Default Web service port: 4446++- IPv6 addresses have just to be valid ones, but they are+ stored and returned canonized in conformation with RFC 5952.++- The field "source" takes a schema-free JSON value.++- In case of success, POST, PUT and DELETE returns a HTTP status 204 "No Content".++- The field "ttl" is optional (default to null).++### /ipv6db/v1/list/\{*listName*\}/addresses/{*IPv6Address*}++__POST /ipv6db/v1/list/\{__*listName*__\}/addresses/\{__*IPv6Address*__\}__++Creates a resource.++ POST /ipv6db/v1/list/hosts/addresses/abcd::1234++```json+ {+ "ttl": 3600,+ "source":+ {+ "services": ["smtp","imap"]+ }+ }+```++__PUT /ipv6db/v1/list/\{__*listName*__\}/addresses/\{__*IPv6Address*__\}__++Updates a resource.++```+ PUT /ipv6db/v1/list/hosts/addresses/abcd::1234+```++```json+ {+ "ttl": 3600,+ "source":+ {+ "services": ["smtp","imap","ssh"]+ }+ }+```++Response:++If successful, returns HTTP Status 204 No Content++__GET /ipv6db/v1/list/\{__*listName*__\}/addresses/\{__*IPv6Address*__\}__++```+ GET /ipv6db/v1/list/hosts/addresses/abcd::1234+```++Response:++```json+ {+ "list": "hosts",+ "address": "abcd::1234",+ "ttl": null,+ "source":+ {+ "services": ["smtp","imap","ssh"]+ }+ }+```++__DELETE /ipv6db/v1/list/\{__*listName*__\}/addresses/\{__*IPv6Address*__\}__++```+ DELETE /ipv6db/v1/hosts/addresses/abcd::1234+```++Response:+++### /ipv6db/v1/list/\{*listName*\}/addresses++__POST /ipv6db/v1/list/\{__*listName*__\}/addresses__++Creates many resources that belongs to the given list.++```json+ POST /ipv6db/v1/hosts/addresses+ [+ {+ "address": "abcd::1234",+ "ttl": null,+ "source":+ {+ "services": ["smtp","imap","ssh"]+ }+ },+ {+ "address": "abcd::1235",+ "ttl": null,+ "source":+ {+ "services": ["http","https","ssh"]+ }+ }+ ]+```++__PUT /ipv6db/v1/list/\{__*listName*__\}/addresses__++Updates many resources that belongs to the given list.++```json+ PUT /ipv6db/v1/hosts/addresses+ [+ {+ "address": "abcd::1234",+ "ttl": null,+ "source":+ {+ "services": ["smtp","imap","ssh"]+ }+ },+ {+ "address": "abcd::1235",+ "ttl": null,+ "source":+ {+ "services": ["http","https","ssh"]+ }+ }+ ]+```++__GET /ipv6db/v1/list/\{__*listName*__\}/addresses__++Gets many resources from the list based on a JSON array of IPv6 addresses.++```json+ GET /ipv6db/v1/hosts/addresses+ [+ "abcd::1234",+ "abcd::1235"+ ]+```++__DELETE /ipv6db/v1/list/\{__*listName*__\}/addresses__++Deletes many resources from the list based on a JSON array of IPv6 addresses.++```json+ DELETE /ipv6db/v1/hosts/addresses+ [+ "abcd::1234",+ "abcd::1235"+ ]+```++### /ipv6db/v1/batch++__PUT /ipv6db/v1/batch__++Updates many resources possibly from different lists based on a JSON array.++```json+ PUT /ipv6db/v1/batch+ [+ {+ "list": "hosts",+ "address": "abcd::1234",+ "ttl": null,+ "source":+ {+ "services": ["smtp","imap"]+ }+ },+ {+ "list": "blacklist",+ "address": "bad::1235",+ "ttl": 604800,+ "source": null+ }+ ]+```++__GET /ipv6db/v1/batch__++Gets many resources possibly from different lists based on a JSON array.++```json+ GET /ipv6db/v1/batch+ [+ {+ "list": "hosts",+ "address": "abcd::1234"+ },+ {+ "list": "blacklist",+ "address": "bad::1234"+ }+ ]+```++__DELETE /ipv6db/v1/batch__++Deletes many resources possibly from different lists based on a JSON array.++```json+ DELETE /ipv6db/v1/batch+ [+ {+ "list": "hosts",+ "address": "abcd::1234"+ },+ {+ "list": "backlist",+ "address": "bad::1234"+ }+ ]+```+
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2017, Michel Boucey+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 IPv6DB nor the names of its+ 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 HOLDER 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.+
+ README.md view
@@ -0,0 +1,46 @@+# IPv6DB++## A RESTful Web service for IPv6 related data [](https://travis-ci.org/MichelBoucey/IPv6DB)++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. Each resource can be permanent or TTLed.++```bash+[user@box ~]$ ipv6db --help+IPv6DB v0.1.0 APIv1, (c) Michel Boucey 2017++Usage: ipv6db [-p|--port] [-h|--redis-host ARG] [-r|--redis-port]+ [-d|--redis-database ARG] [-a|--redis-auth ARG]+ [-l|--log-file ARG]+ RESTful Web Service for IPv6 related data++Available options:+ -p,--port Alternative listening port (default: 4446)+ -l,--log-file ARG Log file (default: "/var/log/ipv6db.log")+ -h,--redis-host ARG Redis host (default: "localhost")+ -r,--redis-port Redis listening port (default: 6379)+ -d,--redis-database ARG Redis database (default: 0)+ -a,--redis-auth ARG Redis authentication password+ -h,--help Show this help text+```++A resource example:++```json+ {+ "list": "black",+ "address": "abcd::1234",+ "ttl": 34582,+ "source":+ {+ "services": [25,587,143]+ }+ }+```++The field "source" is mandatory and carry any valid JSON value.++The field "ttl" is optional in API requests for a permanent resource.++See the full [IPv6DB APIv1](https://github.com/MichelBoucey/IPv6DB/blob/master/IPv6DB_APIv1.md).++The package includes binary and library.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader+import Data.Aeson as A+import qualified Data.ByteString.Lazy as BSL+import Data.Maybe (fromJust)+import Data.Monoid ((<>))+import qualified Data.Vector as V+import Database.Redis hiding (String)+import Network.HTTP.Types hiding (noContent204)+import Network.IPv6DB.Types+import Network.Wai+import Network.Wai.Handler.Warp+import Network.Wai.Logger+import Options.Applicative (execParser)+import Prelude hiding (error)+import System.Log.FastLogger+import Text.IPv6Addr++import Options+import Queries+import Types++main :: IO ()+main = do+ Options{..} <- execParser opts+ timeCache <- newTimeCache simpleTimeFormat+ apLog <- apacheLogger <$>+ initLogger+ FromSocket+ (LogFileNoRotate logFile defaultBufSize)+ timeCache+ run appPort (ipv6db apLog)++ipv6db :: ApacheLogger -> Application+ipv6db logger req res = do+ Options{..} <- execParser opts+ conn <- checkedConnect $+ defaultConnectInfo+ { connectHost = redisHost+ , connectPort = PortNumber (fromInteger redisPort)+ , connectAuth = redisAuth+ , connectDatabase = redisDatabase }+ withEnv Env { redisConn = conn } $+ case parseMethod (requestMethod req) of+ Right mtd ->+ case pathInfo req of++ ["ipv6db", "v1", "batch"] ->+ batchHandler mtd++ ["ipv6db", "v1", "list", list, "addresses"] ->+ listHandler mtd list++ ["ipv6db", "v1", "list", list, "addresses", addr] ->+ listAddressHandler mtd list addr++ _ -> liftIO (jsonError "Bad URI Request")+ Left _ -> liftIO (jsonError "Bad HTTP Method")+ where++ withEnv = flip runReaderT++ maybeJSONBody :: FromJSON a => IO (Maybe a)+ maybeJSONBody = A.decode <$> strictRequestBody req++ logWith status = liftIO (logger req status Nothing)++ -- -------------------------------------------------------------------- --+ -- Endpoint handlers --+ -- -------------------------------------------------------------------- --++ batchHandler mtd = do+ 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++ 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++ 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+ _ -> 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+ let rsrcs =+ (\o -> maybeResource o [("list",String list)]) <$> V.toList v+ if Nothing `notElem` rsrcs+ then do+ results <- mapM (setSource redisConn mtd' . fromJust) rsrcs+ if all (== RedisOk) results+ 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++ DELETE -> do+ mjson <- maybeJSONBody+ case mjson of+ Just addrs -> do+ ed <- runRedis redisConn (delByAddresses list addrs)+ case ed of+ 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 ->+ case maybeResource o [("list", String list),("address", String addr)] of+ Just rsrc -> do+ rdres <- setSource redisConn mtd' rsrc+ case rdres of+ 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+ Right msrc ->+ case msrc of+ Just src -> do+ ttls <- ttlSource redisConn list addr'+ case toResource list addr' ttls src of+ Just rsrc -> jsonOk (A.encode rsrc)+ Nothing -> jsonError "Can't Build Resource"+ Nothing ->+ jsonRes404 $+ encode $+ ResourceError+ list+ (IPv6Addr addr')+ "Resource Not Found"+ Left _ -> jsonError "Backend Error"+ Nothing -> jsonError "Not IPv6 Address in URI"++ DELETE ->+ case maybeIPv6Addr addr of+ Just (IPv6Addr addr') -> do+ er <- liftIO (runRedis redisConn $ delSource list addr')+ case er of+ Right i ->+ case i of+ 1 -> noContent204+ _ ->+ jsonRes404 $+ encode $+ ResourceError+ list+ (IPv6Addr addr')+ "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)++ noContent204 = do+ logWith status204+ res (responseLBS status204 [] BSL.empty)++ jsonRes400 bs = do+ logWith status400+ res (jsonRes status400 bs)++ badJSONRequest = do+ logWith status400+ jsonError "Bad JSON Request"++ jsonError err = do+ logWith status400+ res (jsonRes status400 $ justError err)++ jsonRes404 bs = do+ logWith status404+ res (jsonRes status404 bs)++ methodNotAllowed = do+ logWith status405+ res (jsonRes status405 $ justError "Method Not Allowed")++ jsonServerError err = do+ logWith status500+ res (jsonRes status500 $ justError err)++ jsonRes status =+ responseLBS+ status+ [ ("Content-Type", "application/json; charset=utf-8") ]++ justError err = "{\"error\":\"" <> err <> "\"}"+
+ app/Options.hs view
@@ -0,0 +1,70 @@++module Options where++import Data.ByteString+import Data.Monoid ((<>))+import Options.Applicative++data Options =+ Options+ { appPort :: Int+ , logFile :: String+ , redisHost :: String+ , redisPort :: Integer+ , redisDatabase :: Integer+ , redisAuth :: Maybe ByteString+ }++opts :: ParserInfo Options+opts = info (options <**> helper)+ ( fullDesc+ <> progDesc "RESTful Web Service for IPv6 related data"+ <> header "IPv6DB v0.1.0 APIv1, (c) Michel Boucey 2017" )++options :: Parser Options+options =+ Options+ <$>+ option auto+ ( short 'p'+ <> long "port"+ <> help "Alternative listening port"+ <> showDefault+ <> value 4446+ <> metavar "" )+ <*>+ strOption+ ( short 'l'+ <> long "log-file"+ <> help "Log file"+ <> showDefault+ <> value "/var/log/ipv6db.log" )+ <*>+ strOption+ ( short 'h'+ <> long "redis-host"+ <> help "Redis host"+ <> showDefault+ <> value "localhost" )+ <*>+ option auto+ ( short 'r'+ <> long "redis-port"+ <> help "Redis listening port"+ <> showDefault+ <> value 6379+ <> metavar "" )+ <*>+ option auto+ ( short 'd'+ <> long "redis-database"+ <> help "Redis database"+ <> showDefault+ <> value 0 )+ <*>+ option auto+ ( short 'a'+ <> long "redis-auth"+ <> help "Redis authentication password"+ <> value Nothing )+
+ app/Queries.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Queries where++import Control.Monad (zipWithM)+import Control.Monad.Reader+import Data.Aeson as A+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.HashMap.Lazy+import Data.Maybe (fromJust)+import Data.Monoid ((<>))+import qualified Data.Text as T+import Data.Text.Encoding+import Database.Redis as R hiding (decode)+import Network.HTTP.Types (StdMethod (..))+import Network.IPv6DB.Types+import Text.IPv6Addr++import Types++fromEntries :: (MonadReader Env f, MonadIO f)+ => Entries+ -> [Maybe BS.ByteString]+ -> f BSL.ByteString+fromEntries (Entries ents) msrcs =+ encode <$> zipWithM toJson ents msrcs+ where+ toJson Entry{..} (Just src) = do+ Env{..} <- ask+ liftIO (buildResource redisConn list address src)+ toJson Entry{..} Nothing =+ return (ResourceError list address "Resource Not Found")++fromAddresses :: (MonadReader Env f, MonadIO f)+ => T.Text+ -> Addresses+ -> [Maybe BS.ByteString]+ -> f BSL.ByteString+fromAddresses list (Addresses addrs) msrcs =+ encode <$> zipWithM toJson addrs msrcs+ where+ toJson addr (Just src) = do+ Env{..} <- ask+ liftIO (buildResource redisConn list addr src)+ toJson addr Nothing =+ return (ResourceError list addr "Resource Not Found")++buildResource :: Connection+ -> T.Text+ -> IPv6Addr+ -> BS.ByteString+ -> IO Resource+buildResource conn list (IPv6Addr addr) src = do+ mttl <- ttlSource conn list addr+ return (fromJust $ toResource list addr mttl src)++setSource ::Connection -> StdMethod -> Resource -> IO RedisResponse+setSource _ _ ResourceError{} = undefined+setSource conn mtd Resource{ttl=ttlr,..} = do+ er <- runRedis conn $ setOpts+ (toKey list $ fromIPv6Addr address)+ (BSL.toStrict $ encode source)+ SetOpts+ { setSeconds = ttlr+ , setMilliseconds = Nothing+ , setCondition =+ case mtd of+ PUT -> Just Xx+ POST -> Just Nx+ _ -> Nothing+ }+ return $+ case er of+ Right s ->+ case s of+ Ok -> RedisOk+ Status status -> toRedisError list address status+ Pong -> toRedisError list address "Ping!"+ Left r ->+ case r of+ R.Error err -> toRedisError list address err+ R.Bulk Nothing ->+ case mtd of+ PUT ->+ toRedisError+ list+ address+ "The Resource Doesn't Exist Yet (Use POST To Create It)"+ POST ->+ toRedisError+ list+ address+ "The Resource Already Exists (Use PUT To Replace It)"+ _ ->+ toRedisError+ list+ address+ "HTTP Method Not Handled"+ R.Bulk (Just bs) -> toRedisError list address bs+ _ ->+ toRedisError+ list+ address+ "Undefined Redis Error"++toRedisError :: T.Text+ -> IPv6Addr+ -> BS.ByteString+ -> RedisResponse+toRedisError list addr err =+ RedisError+ { entry = toEntry list addr+ , error = err+ }++ttlSource :: Connection+ -> T.Text+ -> T.Text+ -> IO (Maybe Integer)+ttlSource conn list addr = do+ ettl <- R.runRedis conn (R.ttl $ toKey list addr)+ return $+ case ettl of+ Right i ->+ if i > 0+ then Just i+ else Nothing+ Left _ -> Nothing++getSource :: RedisCtx m f+ => T.Text+ -> T.Text+ -> m (f (Maybe BS.ByteString))+getSource list addr = get (toKey list addr)++delSource :: RedisCtx m f+ => T.Text+ -> T.Text+ -> m (f Integer)+delSource list addr = del [ toKey list addr ]++toResource :: T.Text+ -> T.Text+ -> Maybe Integer+ -> BS.ByteString+ -> Maybe Resource+toResource list addr mi bs =+ case decode (BSL.fromStrict bs) of+ Just src -> Just+ Resource+ { list = list+ , address = IPv6Addr addr+ , ttl = mi+ , source = Source src+ }+ Nothing -> Nothing++maybeResource :: Value+ -> [(T.Text,Value)]+ -> Maybe Resource+maybeResource v prs =+ case v of+ Object hm -> do+ let hm' =+ if member "ttl" hm+ then hm+ else insert "ttl" Null hm+ case fromJSON (Object $ union hm' $ fromList prs) of+ A.Success r -> Just r+ A.Error _ -> Nothing+ _ -> Nothing++listAddressSeparator :: T.Text+getByAddresses :: RedisCtx m f+ => T.Text+ -> Addresses+ -> m (f [Maybe BS.ByteString])+getByAddresses list addrs =+ mget (addressesToKeys list addrs)++getByEntries :: RedisCtx m f+ => Entries+ -> m (f [Maybe BS.ByteString])+getByEntries ents = mget (fromEnts ents)++delByAddresses :: RedisCtx m f+ => T.Text+ -> Addresses -> m (f Integer)+delByAddresses list addrs =+ del (addressesToKeys list addrs)++delByEntries :: RedisCtx m f+ => Entries+ -> m (f Integer)+delByEntries ents = del (fromEnts ents)++addressesToKeys :: T.Text+ -> Addresses+ -> [BS.ByteString]+addressesToKeys list (Addresses addrs) =+ toKey list . fromIPv6Addr <$> addrs++fromEnts :: Entries -> [BS.ByteString]+fromEnts (Entries ents) =+ (\Entry{..} -> toKey list (fromIPv6Addr address)) <$> ents++toEntry :: T.Text -> IPv6Addr -> Entry+toEntry list address = Entry { list = list, address = address }++toKey :: T.Text -> T.Text -> BS.ByteString+toKey list addr =+ encodeUtf8 (list <> listAddressSeparator <> addr)++listAddressSeparator = "/"+
+ app/Types.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Types where++import Database.Redis+import Data.Aeson as A+import qualified Data.ByteString as BS+import Data.Text.Encoding+import qualified Data.Vector as V+import Prelude hiding (error)++import Network.IPv6DB.Types++data Env = Env { redisConn :: Connection }++data RedisResponse+ = RedisOk+ | RedisError+ { entry :: !Entry+ , error :: !BS.ByteString+ }+ deriving (Eq, Show)++instance ToJSON RedisResponse where+ toJSON RedisError{entry=Entry{..},..} =+ object+ [ "list" .= list+ , "address" .= address+ , "error" .= decodeUtf8 error+ ]+ toJSON _ = Null++data RedisErrors = RedisErrors [RedisResponse] deriving (Eq, Show)++instance ToJSON RedisErrors where+ toJSON (RedisErrors rrs) =+ object+ [ ("errors", Array $ V.fromList $ toJSON <$> filter (/= RedisOk) rrs) ]+
+ src/Network/IPv6DB/Types.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Network.IPv6DB.Types where++import Data.Aeson as A+import qualified Data.Text as T+import qualified Data.Vector as V+import Text.IPv6Addr++data Addresses = Addresses [IPv6Addr]++instance FromJSON Addresses where+ parseJSON (Array v) = do+ let rslts = fromJSON <$> V.toList v+ if all isSuccess rslts+ then pure (Addresses $ fromSuccess <$> rslts)+ else fail "Bad JSON Array Of IPv6 Addresses"+ parseJSON _ = fail "JSON Array Expected"++data Entry =+ Entry+ { list :: !T.Text+ , address :: !IPv6Addr+ } deriving (Eq, Show)++instance FromJSON Entry where+ parseJSON (Object o) = do+ list <- o .: "list"+ address <- o .: "address"+ pure Entry{..}+ parseJSON _ = fail "JSON Object Expected"++data Entries = Entries [Entry]++instance FromJSON Entries where+ parseJSON (Array v) = do+ let ents = fromJSON <$> V.toList v+ if all isSuccess ents+ then pure (Entries $ fromSuccess <$> ents)+ else fail "Malformed JSON Array"+ parseJSON _ = fail "JSON Array Expected"++data Source = Source !Value deriving (Eq, Show)++instance ToJSON Source where+ toJSON (Source v) = v++instance FromJSON Source where+ parseJSON v = pure (Source v)++data Resource+ = Resource+ { list :: !T.Text+ , address :: !IPv6Addr+ , ttl :: !(Maybe Integer)+ , source :: !Source+ }+ | ResourceError+ { list :: !T.Text+ , address :: !IPv6Addr+ , error :: !T.Text+ } + deriving (Eq, Show)++instance ToJSON Resource where+ toJSON Resource{..} =+ object+ [ "list" .= list+ , "address" .= address+ , "ttl" .= ttl+ , "source" .= source+ ]+ toJSON ResourceError{error=err, ..} =+ object+ [ "list" .= list+ , "address" .= address+ , "error" .= err+ ]++instance FromJSON Resource where+ parseJSON =+ withObject "resource" $+ \o -> do+ list <- o .: "list"+ address <- do+ ma <- o .: "address"+ case maybeIPv6Addr ma of+ Just a -> pure a+ Nothing -> fail "Not an IPv6 Address"+ ttl <- o .:? "ttl"+ source <- o .: "source"+ return Resource{..}++data Resources = Resources [Resource] deriving (Eq, Show)++instance ToJSON Resources where+ toJSON (Resources rs) =+ object [ ("resources", Array (V.fromList $ toJSON <$> rs)) ]++instance FromJSON Resources where+ parseJSON (Array v) = do+ let rsrcs = fromJSON <$> V.toList v+ if all isSuccess rsrcs+ then pure (Resources $ fromSuccess <$> rsrcs)+ else fail "Malformed JSON Array Of Resources"+ parseJSON _ = fail "JSON Array Expected"++isSuccess :: Result a -> Bool+isSuccess (A.Success _) = True+isSuccess (A.Error _) = False++fromSuccess :: Result a -> a+fromSuccess (A.Success e) = e+fromSuccess (A.Error _) = Prelude.error "Success value only"+
+ tests/hspec.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE OverloadedStrings #-}++import Data.Aeson+import Network.HTTP.Client+import Network.HTTP.Types.Status (statusCode)+import Data.Vector+import Test.Hspec++import Network.IPv6DB.Types++main :: IO ()+main = hspec $ do++ describe "POST /ipv6db/v1/list/test0/addresses/abcd::1234" $++ it "Creates the resource" $ do++ mngr <- newManager defaultManagerSettings+ initReq <- parseRequest "http://localhost:4446/ipv6db/v1/list/test0/addresses/abcd::1234"+ let req = initReq+ { method = "POST"+ , requestBody =+ RequestBodyLBS $+ encode (object [("ttl", Null),("source", object [("data",String "A B C D")])]) }+ res <- httpLbs req mngr+ statusCode (responseStatus res) `shouldBe` 204++ describe "PUT /ipv6db/v1/list/test0/addresses/abcd::1234" $++ it "Updates the resource" $ do++ mngr <- newManager defaultManagerSettings+ initReq <- parseRequest "http://localhost:4446/ipv6db/v1/list/test0/addresses/abcd::1234"+ let req = initReq+ { method = "PUT"+ , requestBody =+ RequestBodyLBS $+ encode (object [("ttl", Null),("source", object [("data",String "E F G H")])])+ }+ res <- httpLbs req mngr+ statusCode (responseStatus res) `shouldBe` 204++ describe "GET /ipv6db/v1/list/test0/addresses/abcd::1234" $++ it "Gets the resource" $ do++ mngr <- newManager defaultManagerSettings+ req <- parseRequest "http://localhost:4446/ipv6db/v1/list/test0/addresses/abcd::1234"+ res <- httpLbs req mngr+ responseBody res `shouldBe` "{\"ttl\":null,\"list\":\"test0\",\"address\":\"abcd::1234\",\"source\":{\"data\":\"E F G H\"}}"++ describe "DELETE /ipv6db/v1/list/test0/addresses/abcd::1234" $++ it "Deletes the resource" $ do++ mngr <- newManager defaultManagerSettings+ initReq <- parseRequest "http://localhost:4446/ipv6db/v1/list/test0/addresses/abcd::1234"+ let req = initReq { method = "DELETE" }+ res <- httpLbs req mngr+ statusCode (responseStatus res) `shouldBe` 204++ describe "POST /ipv6db/v1/list/test0/addresses" $++ it "Creates resources for the given list" $ do++ mngr <- newManager defaultManagerSettings+ initReq <- parseRequest "http://localhost:4446/ipv6db/v1/list/test0/addresses"+ let req = initReq+ { method = "POST"+ , requestBody =+ RequestBodyLBS $+ encode $+ Array $+ fromList+ [ object+ [ ("address","abcd::1234")+ , ("ttl", Null)+ , ("source", object [ ("data", String "E F G H") ])+ ]+ , object+ [ ("address","abcd::5678")+ , ("ttl", Null)+ , ("source", object [ ("data", String "I J K L") ])+ ]+ ]+ }+ res <- httpLbs req mngr+ statusCode (responseStatus res) `shouldBe` 204++ describe "PUT /ipv6db/v1/list/test0/addresses" $++ it "Updates the resources that belong to the given list" $ do++ mngr <- newManager defaultManagerSettings+ initReq <- parseRequest "http://localhost:4446/ipv6db/v1/list/test0/addresses"+ let req = initReq+ { method = "PUT"+ , requestBody =+ RequestBodyLBS $+ encode $+ Array $+ fromList+ [ object+ [ ("address","abcd::1234")+ , ("ttl", Null)+ , ("source", object [ ("data", String "H G F E") ])+ ]+ , object+ [ ("address","abcd::5678")+ , ("ttl", Null)+ , ("source", object [ ("data", String "L K J I") ])+ ]+ ]+ }+ res <- httpLbs req mngr+ statusCode (responseStatus res) `shouldBe` 204++ describe "GET /ipv6db/v1/list/test0/addresses" $++ it "Gets the resources that belong to the given list" $ do++ mngr <- newManager defaultManagerSettings+ initReq <- parseRequest "http://localhost:4446/ipv6db/v1/list/test0/addresses"+ let req = initReq+ { requestBody =+ RequestBodyLBS $+ encode $+ Array $+ fromList+ [ String "abcd::1234"+ , String "abcd::5678"+ ]+ }+ res <- httpLbs req mngr+ responseBody res `shouldBe` "[{\"ttl\":null,\"list\":\"test0\",\"address\":\"abcd::1234\",\"source\":{\"data\":\"H G F E\"}},{\"ttl\":null,\"list\":\"test0\",\"address\":\"abcd::5678\",\"source\":{\"data\":\"L K J I\"}}]"++ describe "DELETE /ipv6db/v1/list/test0/addresses" $++ it "Deletes the resources that belong to the given list" $ do++ mngr <- newManager defaultManagerSettings+ initReq <- parseRequest "http://localhost:4446/ipv6db/v1/list/test0/addresses"+ let req = initReq+ { method = "DELETE"+ , requestBody =+ RequestBodyLBS $+ encode $+ Array $+ fromList+ [ String "abcd::1234"+ , String "abcd::5678"+ ]+ }+ res <- httpLbs req mngr+ statusCode (responseStatus res) `shouldBe` 204++ describe "POST /ipv6db/v1/batch" $++ it "Creates many resources on different lists" $ do++ mngr <- newManager defaultManagerSettings+ initReq <- parseRequest "http://localhost:4446/ipv6db/v1/batch"+ let req = initReq+ { method = "POST"+ , requestBody =+ RequestBodyLBS $+ encode $+ Array $+ fromList+ [ object+ [ ("list","test1")+ , ("address","abcd::1234")+ , ("ttl", Null)+ , ("source", object [ ("data", String "E F G H") ])+ ]+ , object+ [ ("list","test2")+ , ("address","abcd::5678")+ , ("ttl", Null)+ , ("source", object [ ("data", String "I J K L") ])+ ]+ ]+ }+ res <- httpLbs req mngr+ statusCode (responseStatus res) `shouldBe` 204++ describe "PUT /ipv6db/v1/batch" $++ it "Updates many resources on different lists" $ do++ mngr <- newManager defaultManagerSettings+ initReq <- parseRequest "http://localhost:4446/ipv6db/v1/batch"+ let req = initReq+ { method = "PUT"+ , requestBody =+ RequestBodyLBS $+ encode $+ Array $+ fromList+ [ object+ [ ("list", "test1")+ , ("address", "abcd::1234")+ , ("ttl", Null)+ , ("source", object [ ("data", String "1 2 3 4") ])+ ]+ , object+ [ ("list", "test2")+ , ("address", "abcd::5678")+ , ("ttl", Null)+ , ("source", object [ ("data", String "5 6 7 8") ])+ ]+ ]+ }+ res <- httpLbs req mngr+ statusCode (responseStatus res) `shouldBe` 204++ describe "GET /ipv6db/v1/batch" $++ it "Gets many resources on different lists" $ do++ mngr <- newManager defaultManagerSettings+ initReq <- parseRequest "http://localhost:4446/ipv6db/v1/batch"+ let req = initReq+ { requestBody =+ RequestBodyLBS $+ encode $+ Array $+ fromList+ [ object+ [ ("list", "test1")+ , ("address", "abcd::1234")+ ]+ , object+ [ ("list", "test2")+ , ("address", "abcd::5678")+ ]+ ]+ }+ res <- httpLbs req mngr+ responseBody res `shouldBe` "[{\"ttl\":null,\"list\":\"test1\",\"address\":\"abcd::1234\",\"source\":{\"data\":\"1 2 3 4\"}},{\"ttl\":null,\"list\":\"test2\",\"address\":\"abcd::5678\",\"source\":{\"data\":\"5 6 7 8\"}}]"++ describe "DELETE /ipv6db/v1/batch" $++ it "Deletes many resources on different lists" $ do++ mngr <- newManager defaultManagerSettings+ initReq <- parseRequest "http://localhost:4446/ipv6db/v1/batch"+ let req = initReq+ { method = "DELETE"+ , requestBody =+ RequestBodyLBS $+ encode $+ Array $+ fromList+ [ object+ [ ("list", "test1")+ , ("address", "abcd::1234")+ ]+ , object+ [ ("list", "test2")+ , ("address", "abcd::5678")+ ]+ ]+ }+ res <- httpLbs req mngr+ statusCode (responseStatus res) `shouldBe` 204+