{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings  #-}
module Database.Persist.Instances.IP where

#if __GLASGOW_HASKELL__ <= 708
import Control.Applicative (pure, (<$>))
#endif
import Data.Aeson.IP ()
import Data.ByteString.Char8 (ByteString, pack,unpack)
import Data.IP (IPRange, IP)
import qualified Data.Text as T
import Database.Persist
import Database.Persist.Sql
import Text.Read (readMaybe)
import Web.HttpApiData (ToHttpApiData(..),FromHttpApiData(..))
import Web.PathPieces (PathPiece(..))

note :: Maybe b -> T.Text -> Either T.Text b
{-# INLINE note #-}
note :: Maybe b -> Text -> Either Text b
note Maybe b
x Text
y = Either Text b -> (b -> Either Text b) -> Maybe b -> Either Text b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text b
forall a b. a -> Either a b
Left Text
y) b -> Either Text b
forall a b. b -> Either a b
Right Maybe b
x

ctor :: ByteString -> PersistValue
{-# INLINE ctor #-}

ctorName :: T.Text
{-# INLINE ctorName #-}

unCtor :: PersistValue -> Maybe ByteString
{-# INLINE unCtor #-}

#if MIN_VERSION_persistent(2,11,0)
ctor :: ByteString -> PersistValue
ctor = ByteString -> PersistValue
PersistLiteralEscaped
ctorName :: Text
ctorName = Text
"PersistLiteralEscaped"
unCtor :: PersistValue -> Maybe ByteString
unCtor PersistValue
x = case PersistValue
x of {PersistLiteralEscaped ByteString
y -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
y; PersistValue
_ -> Maybe ByteString
forall a. Maybe a
Nothing}
#else
ctor = PersistDbSpecific
ctorName = "PersistDbSpecific"
unCtor x = case x of {PersistDbSpecific y -> Just y; _ -> Nothing}
#endif

instance PersistField IP where
    toPersistValue :: IP -> PersistValue
toPersistValue = ByteString -> PersistValue
ctor (ByteString -> PersistValue)
-> (IP -> ByteString) -> IP -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
pack (String -> ByteString) -> (IP -> String) -> IP -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IP -> String
forall a. Show a => a -> String
show

    fromPersistValue :: PersistValue -> Either Text IP
fromPersistValue PersistValue
pval = do
        ByteString
ipBS <- PersistValue -> Maybe ByteString
unCtor PersistValue
pval Maybe ByteString -> Text -> Either Text ByteString
forall b. Maybe b -> Text -> Either Text b
`note` [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
"IP must be converted from ", Text
ctorName]
        let ipStr :: String
ipStr = ByteString -> String
unpack ByteString
ipBS
        String -> Maybe IP
forall a. Read a => String -> Maybe a
readMaybe String
ipStr Maybe IP -> Text -> Either Text IP
forall b. Maybe b -> Text -> Either Text b
`note` [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
"Unable to parse IP: ", String -> Text
T.pack String
ipStr]

instance PersistFieldSql IP where
#ifdef USE_IP4R
    sqlType _ = SqlOther "IPADDRESS"
#else
    sqlType :: Proxy IP -> SqlType
sqlType Proxy IP
_ = Text -> SqlType
SqlOther Text
"INET"
#endif

instance PersistField IPRange where
    toPersistValue :: IPRange -> PersistValue
toPersistValue = ByteString -> PersistValue
ctor (ByteString -> PersistValue)
-> (IPRange -> ByteString) -> IPRange -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
pack (String -> ByteString)
-> (IPRange -> String) -> IPRange -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPRange -> String
forall a. Show a => a -> String
show

    fromPersistValue :: PersistValue -> Either Text IPRange
fromPersistValue PersistValue
pval = do
        ByteString
iprBS <- PersistValue -> Maybe ByteString
unCtor PersistValue
pval Maybe ByteString -> Text -> Either Text ByteString
forall b. Maybe b -> Text -> Either Text b
`note` [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
"IPRange must be converted from ", Text
ctorName]
        let iprStr :: String
iprStr = ByteString -> String
unpack ByteString
iprBS
        String -> Maybe IPRange
forall a. Read a => String -> Maybe a
readMaybe String
iprStr Maybe IPRange -> Text -> Either Text IPRange
forall b. Maybe b -> Text -> Either Text b
`note` [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
"Unable to parse IPRange: ", String -> Text
T.pack String
iprStr]

instance PersistFieldSql IPRange where
#ifdef USE_IP4R
    sqlType _ = SqlOther "IPRANGE"
#else
    sqlType :: Proxy IPRange -> SqlType
sqlType Proxy IPRange
_ = Text -> SqlType
SqlOther Text
"CIDR"
#endif


-- The following instances don't really make sense, but persistent
-- requires them so I defined them anyway.
instance PathPiece IPRange where
    fromPathPiece :: Text -> Maybe IPRange
fromPathPiece = String -> Maybe IPRange
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe IPRange)
-> (Text -> String) -> Text -> Maybe IPRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"%2F" Text
"/"
    toPathPiece :: IPRange -> Text
toPathPiece = Text -> Text -> Text -> Text
T.replace Text
"/" Text
"%2F" (Text -> Text) -> (IPRange -> Text) -> IPRange -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (IPRange -> String) -> IPRange -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPRange -> String
forall a. Show a => a -> String
show

instance PathPiece IP where
    fromPathPiece :: Text -> Maybe IP
fromPathPiece = String -> Maybe IP
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe IP) -> (Text -> String) -> Text -> Maybe IP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
    toPathPiece :: IP -> Text
toPathPiece = String -> Text
T.pack (String -> Text) -> (IP -> String) -> IP -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IP -> String
forall a. Show a => a -> String
show

instance ToHttpApiData IP where
    toUrlPiece :: IP -> Text
toUrlPiece = String -> Text
T.pack (String -> Text) -> (IP -> String) -> IP -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IP -> String
forall a. Show a => a -> String
show

instance ToHttpApiData IPRange where
    toUrlPiece :: IPRange -> Text
toUrlPiece = Text -> Text -> Text -> Text
T.replace Text
"/" Text
"%2F" (Text -> Text) -> (IPRange -> Text) -> IPRange -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (IPRange -> String) -> IPRange -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPRange -> String
forall a. Show a => a -> String
show

instance FromHttpApiData IP where
    parseUrlPiece :: Text -> Either Text IP
parseUrlPiece Text
txt
        | Just IP
ip <- String -> Maybe IP
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe IP) -> String -> Maybe IP
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
txt = IP -> Either Text IP
forall a b. b -> Either a b
Right IP
ip
        | Bool
otherwise = Text -> Either Text IP
forall a b. a -> Either a b
Left (Text -> Either Text IP) -> Text -> Either Text IP
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
"Unable to parse IP: ", Text
txt]

instance FromHttpApiData IPRange where
    parseUrlPiece :: Text -> Either Text IPRange
parseUrlPiece Text
txt
        | Just IPRange
ipr <- String -> Maybe IPRange
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe IPRange)
-> (Text -> String) -> Text -> Maybe IPRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Maybe IPRange) -> Text -> Maybe IPRange
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
T.replace Text
"%2F" Text
"/" Text
txt = IPRange -> Either Text IPRange
forall a b. b -> Either a b
Right IPRange
ipr
        | Bool
otherwise = Text -> Either Text IPRange
forall a b. a -> Either a b
Left (Text -> Either Text IPRange) -> Text -> Either Text IPRange
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
"Unable to parse IPRange: ", Text
txt]