diff --git a/IPv6DB.cabal b/IPv6DB.cabal new file mode 100644 --- /dev/null +++ b/IPv6DB.cabal @@ -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 diff --git a/IPv6DB_APIv1.md b/IPv6DB_APIv1.md new file mode 100644 --- /dev/null +++ b/IPv6DB_APIv1.md @@ -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" + } + ] +``` + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,46 @@ +# IPv6DB + +## A RESTful Web service for IPv6 related data [![Build Status](https://travis-ci.org/MichelBoucey/IPv6DB.svg?branch=master)](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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 <> "\"}" + diff --git a/app/Options.hs b/app/Options.hs new file mode 100644 --- /dev/null +++ b/app/Options.hs @@ -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 ) + diff --git a/app/Queries.hs b/app/Queries.hs new file mode 100644 --- /dev/null +++ b/app/Queries.hs @@ -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 = "/" + diff --git a/app/Types.hs b/app/Types.hs new file mode 100644 --- /dev/null +++ b/app/Types.hs @@ -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) ] + diff --git a/src/Network/IPv6DB/Types.hs b/src/Network/IPv6DB/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/IPv6DB/Types.hs @@ -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" + diff --git a/tests/hspec.hs b/tests/hspec.hs new file mode 100644 --- /dev/null +++ b/tests/hspec.hs @@ -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 +