module Network.HTTP.QueryString.Pickle
(
IsQuery (..)
, toQuery
, fromQuery
, encodeQuery
, decodeQuery
, Query (..)
, QueryPU (..)
, QueryOptions (..)
, defaultQueryOptions
, loweredQueryOptions
, GIsQuery (..)
, genericQueryPickler
, qpWrap
, qpElem
, qpPair
, qpLift
, qpPrim
, qpOption
, qpDefault
, qpSum
, qpEither
, qpOrdinalList
, qpList
) where
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.Char (isUpper, isLower, toLower)
import Data.Either
import Data.Foldable (foldl')
import Data.List (sort)
import Data.Monoid
import Data.Text (Text)
import Data.Text.Encoding
import GHC.Generics
class IsQuery a where
queryPickler :: PU a
default queryPickler :: (Generic a, GIsQuery (Rep a)) => PU a
queryPickler = genericQueryPickler defaultQueryOptions
data Query
= List [Query]
| Pair ByteString Query
| Value ByteString
deriving (Eq, Show)
instance Ord Query where
compare (List ls) (List rs) = ls `compare` rs
compare (Pair k1 _) (Pair k2 _) = k1 `compare` k2
compare (Value v1) (Value v2) = v1 `compare` v2
compare (List _) (Pair _ _) = GT
compare (List _) (Value _) = GT
compare (Pair _ _) (Value _) = GT
compare _ _ = LT
instance Monoid Query where
mempty = List []
mappend (List l) (List r) = List $ l ++ r
mappend (List l) r = List $ r : l
mappend l (List r) = List $ l : r
mappend l r = List [l, r]
data QueryPU a = QueryPU
{ pickle :: a -> Query
, unpickle :: Query -> Either String a
}
type PU = QueryPU
data QueryOptions = QueryOptions
{ queryCtorModifier :: String -> String
, queryFieldModifier :: String -> String
}
defaultQueryOptions :: QueryOptions
defaultQueryOptions = QueryOptions id dropLower
loweredQueryOptions :: QueryOptions
loweredQueryOptions = defaultQueryOptions
{ queryFieldModifier = map toLower . dropLower
}
dropLower :: String -> String
dropLower s
| any isUpper s = dropWhile isLower s
| otherwise = s
toQuery :: IsQuery a => a -> [(ByteString, ByteString)]
toQuery = enc "" . pickle queryPickler
where
enc k (List qs) = concatMap (enc k) qs
enc k (Value v) = [(k, v)]
enc k (Pair k' q)
| BS.null k = enc k' q
| otherwise = enc (k <> "." <> k') q
fromQuery :: IsQuery a => [(ByteString, ByteString)] -> Either String a
fromQuery = unpickle queryPickler . foldl' (\a b -> reify b <> a) mempty
where
reify (k, v)
| BS.null k = Value v
| '.' `BS.elem` k = let ks = BS.split '.' k
f k' q = Pair k' q
in foldr f (Pair (last ks) $ Value v) $ init ks
| otherwise = Pair k $ Value v
encodeQuery :: (ByteString -> ByteString)
-> [(ByteString, ByteString)]
-> ByteString
encodeQuery f = BS.intercalate "&" . map (\(k, v) -> mconcat [k, "=", f v]) . sort
decodeQuery :: (ByteString -> ByteString)
-> ByteString
-> [(ByteString, ByteString)]
decodeQuery f = map (pair . BS.split '=')
. BS.split '&'
. BS.dropWhile (\c -> c == '/' || c == '?')
where
pair (k:vs) = (k, f $ BS.intercalate "=" vs)
pair [] = ("", "")
genericQueryPickler opts =
(to, from) `qpWrap` (gQueryPickler opts) (genericQueryPickler opts)
class GIsQuery f where
gQueryPickler :: QueryOptions -> PU a -> PU (f a)
instance IsQuery a => GIsQuery (K1 i a) where
gQueryPickler _ _ = (K1, unK1) `qpWrap` queryPickler
instance GIsQuery U1 where
gQueryPickler _ _ = (const U1, const ()) `qpWrap` qpLift ()
instance GIsQuery a => GIsQuery (M1 i d a) where
gQueryPickler opts = qpWrap (M1, unM1) . gQueryPickler opts
instance CtorIsQuery a => GIsQuery (C1 c a) where
gQueryPickler opts = qpWrap (M1, unM1) . ctorQueryPickler opts
instance ( AllNullary (a :+: b) allNullary
, NullIsQuery (a :+: b) allNullary
) => GIsQuery (a :+: b) where
gQueryPickler opts =
(unTagged :: Tagged allNullary (PU ((a :+: b) d)) -> (PU ((a :+: b) d)))
. nullQueryPickler opts
class NullIsQuery f allNullary where
nullQueryPickler :: QueryOptions -> PU a -> Tagged allNullary (PU (f a))
instance SumIsQuery (a :+: b) => NullIsQuery (a :+: b) True where
nullQueryPickler opts _ = Tagged $ sumQueryPickler opts
instance (GIsQuery a, GIsQuery b) => NullIsQuery (a :+: b) False where
nullQueryPickler opts f = Tagged $
(gQueryPickler opts f `qpSum` gQueryPickler opts f)
class SumIsQuery f where
sumQueryPickler :: QueryOptions -> PU (f a)
instance (SumIsQuery a, SumIsQuery b) => SumIsQuery (a :+: b) where
sumQueryPickler opts = sumQueryPickler opts `qpSum` sumQueryPickler opts
instance Constructor c => SumIsQuery (C1 c U1) where
sumQueryPickler opts = QueryPU
{ pickle = const $ Value name
, unpickle = valueExists
}
where
name = BS.pack . queryCtorModifier opts $ conName (undefined :: t c U1 p)
valueExists qry
| (List [Value v]) <- qry, v == name = Right $ M1 U1
| (Value v) <- qry, v == name = Right $ M1 U1
| otherwise = Left . BS.unpack $ "valueExists: failure - " <> name
class CtorIsQuery f where
ctorQueryPickler :: QueryOptions -> PU a -> PU (f a)
class CtorIsQuery' f isRecord where
ctorQueryPickler' :: QueryOptions -> PU a -> Tagged isRecord (PU (f a))
instance (IsRecord f isRecord, CtorIsQuery' f isRecord) => CtorIsQuery f where
ctorQueryPickler opts = (unTagged :: Tagged isRecord (PU (f a)) -> PU (f a))
. ctorQueryPickler' opts
instance RecIsQuery f => CtorIsQuery' f True where
ctorQueryPickler' opts = Tagged . recQueryPickler opts
instance GIsQuery f => CtorIsQuery' f False where
ctorQueryPickler' opts = Tagged . gQueryPickler opts
class RecIsQuery f where
recQueryPickler :: QueryOptions -> PU a -> PU (f a)
instance (RecIsQuery a, RecIsQuery b) => RecIsQuery (a :*: b) where
recQueryPickler opts f = qpWrap
(uncurry (:*:), \(a :*: b) -> (a, b))
(recQueryPickler opts f `qpPair` recQueryPickler opts f)
instance (Selector s, GIsQuery a) => RecIsQuery (S1 s a) where
recQueryPickler opts f = qpElem
(BS.pack . queryFieldModifier opts $ selName (undefined :: S1 s a r))
((M1, unM1) `qpWrap` gQueryPickler opts f)
instance (Selector s, IsQuery a) => RecIsQuery (S1 s (K1 i (Maybe a))) where
recQueryPickler opts _ =
(M1 . K1, unK1 . unM1) `qpWrap` qpOption (qpElem name queryPickler)
where
name = BS.pack
. queryFieldModifier opts
$ selName (undefined :: t s (K1 i (Maybe a)) p)
class IsRecord (f :: * -> *) isRecord | f -> isRecord
instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord
instance IsRecord (M1 S NoSelector f) False
instance (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord
instance IsRecord (K1 i c) True
instance IsRecord U1 False
class AllNullary (f :: * -> *) allNullary | f -> allNullary
instance ( AllNullary a allNullaryL
, AllNullary b allNullaryR
, And allNullaryL allNullaryR allNullary
) => AllNullary (a :+: b) allNullary
instance AllNullary a allNullary => AllNullary (M1 i c a) allNullary
instance AllNullary (a :*: b) False
instance AllNullary (K1 i c) False
instance AllNullary U1 True
data True
data False
class And bool1 bool2 bool3 | bool1 bool2 -> bool3
instance And True True True
instance And False False False
instance And False True False
instance And True False False
newtype Tagged s b = Tagged { unTagged :: b }
qpWrap :: (a -> b, b -> a) -> PU a -> PU b
qpWrap (f, g) pua = QueryPU
{ pickle = pickle pua . g
, unpickle = fmap f . unpickle pua
}
qpElem :: ByteString -> PU a -> PU a
qpElem name pu = QueryPU
{ pickle = Pair name . pickle pu
, unpickle = \qry -> (unpickle pu =<<) . note qry $ findPair name qry
}
where
note _ = maybe (Right $ List []) Right
findPair k qry
| List qs <- qry = mconcat $ map (findPair k) qs
| Pair k' q <- qry, k == k' = Just q
| otherwise = Nothing
qpPair :: PU a -> PU b -> PU (a, b)
qpPair pua pub = QueryPU
{ pickle = \(a, b) -> pickle pua a <> pickle pub b
, unpickle = \qry -> case (unpickle pua qry, unpickle pub qry) of
(Right a, Right b) -> Right (a, b)
(Left ea, _) -> failure qry $ "left - " ++ ea
(_, Left eb) -> failure qry $ "right - " ++ eb
}
where
failure qry s = Left ("qpPair: " ++ s ++ ", qry: " ++ show qry)
qpLift :: a -> PU a
qpLift x = QueryPU
{ pickle = const $ List []
, unpickle = const $ Right x
}
qpPrim :: (Read a, Show a) => PU a
qpPrim = QueryPU
{ pickle = Value . BS.pack . show
, unpickle = (eitherRead =<<) . findValue
}
where
eitherRead (BS.unpack -> s) = case reads s of
[(x, "")] -> Right x
_ -> Left $ "qpPrim: failed to read value - " ++ s
findValue qry
| List [Value v] <- qry = Right v
| (Value v) <- qry = Right v
| otherwise = Left $ "qpPrim: unexpected non-value - " ++ show qry
qpOption :: PU a -> PU (Maybe a)
qpOption pu = QueryPU
{ pickle = maybe (List []) (pickle pu)
, unpickle = either (const $ Right Nothing) (Right . Just) . unpickle pu
}
qpDefault :: a -> PU a -> PU a
qpDefault x pu = QueryPU
{ pickle = pickle pu
, unpickle = either (const $ Right x) Right . unpickle pu
}
qpSum :: PU (f r) -> PU (g r) -> PU ((f :+: g) r)
qpSum left right = (inp, out) `qpWrap` qpEither left right
where
inp (Left x) = L1 x
inp (Right x) = R1 x
out (L1 x) = Left x
out (R1 x) = Right x
qpEither :: PU a -> PU b -> PU (Either a b)
qpEither pua pub = QueryPU pickleEither unpickleEither
where
unpickleEither qry = either
(handleFailure qry)
(Right . Left) $ unpickle pua qry
handleFailure qry err1 = either
(\err2 -> Left $ "qpEither: both failed - " ++ err1 ++ " - " ++ err2)
(Right . Right) $ unpickle pub qry
pickleEither (Left x) = pickle pua x
pickleEither (Right y) = pickle pub y
qpOrdinalList :: PU a -> PU [a]
qpOrdinalList pu = QueryPU
{ pickle = List . zipWith pickler ([1..] :: [Integer])
, unpickle = \qry -> case qry of
(List qs) -> concatEithers $ map (unpickle pu) [v | Pair _ v <- sort qs]
_ -> Left $ "qpOrdinalList: unexpected non-list - " ++ show qry
}
where
pickler (BS.pack . show -> k) = Pair k . pickle pu
qpList :: PU a -> PU [a]
qpList pu = QueryPU
{ pickle = mconcat . map (pickle pu)
, unpickle = \qry -> case qry of
v@(Value _) -> fmap (:[]) $ unpickle pu v
(List []) -> Right []
(List qs) -> fmap reverse . concatEithers $ map (unpickle pu) qs
_ -> Left $ "qpList: unexpected non-list - " ++ show qry
}
concatEithers :: [Either b c] -> Either b [c]
concatEithers xs = case partitionEithers xs of
(l:_, _) -> Left l
([], rs) -> Right rs
instance IsQuery Char where
queryPickler = QueryPU
{ pickle = Value . BS.singleton
, unpickle = \qry -> case qry of
Value v | BS.length v == 1 -> Right (BS.head v)
_ -> Left $ "qpChar: unexpected value - " ++ show qry
}
instance IsQuery Int where
queryPickler = qpPrim
instance IsQuery Integer where
queryPickler = qpPrim
instance IsQuery ByteString where
queryPickler = QueryPU
{ pickle = Value
, unpickle = \qry -> case qry of
Value v -> Right v
_ -> Left $ "qpByteString: unexpected non-value - " ++ show qry
}
instance IsQuery Text where
queryPickler = (decodeUtf8, encodeUtf8) `qpWrap` queryPickler