module Network.HTTP.Kinder.Query (
QueryEncode (..)
, QueryDecode (..)
, AllQueryEncodes
, AllQueryDecodes
, QueryKeyState (..)
, Flag (..)
, queryEncodePair
) where
import Control.Monad
import Data.Singletons.Prelude
import Data.Singletons.TypeLits
import Data.String
import Data.Text (Text)
import GHC.Exts
import Network.HTTP.Kinder.Common
data Flag = Here | NotHere
data QueryKeyState a
= QueryKeyPresent
| QueryKeyValued a
| QueryKeyAbsent
deriving ( Eq, Ord, Show, Read, Functor )
instance Applicative QueryKeyState where
pure = QueryKeyValued
(<*>) = ap
instance Monad QueryKeyState where
return = pure
m >>= f =
case m of
QueryKeyValued a -> f a
QueryKeyPresent -> QueryKeyPresent
QueryKeyAbsent -> QueryKeyAbsent
class QueryEncode (s :: Symbol) a where
queryEncode :: sing s -> a -> QueryKeyState Text
type family AllQueryEncodes hs :: Constraint where
AllQueryEncodes '[] = ()
AllQueryEncodes ( '(s, a) ': hs ) = (QueryEncode s a, AllQueryEncodes hs)
class QueryDecode (s :: Symbol) a where
queryDecode :: sing s -> QueryKeyState Text -> Either String a
type family AllQueryDecodes hs :: Constraint where
AllQueryDecodes '[] = ()
AllQueryDecodes ( '(s, a) ': hs ) = (QueryDecode s a, AllQueryDecodes hs)
queryEncodePair :: (KnownSymbol n, QueryEncode n a) => Sing n -> a -> Maybe (Text, Maybe Text)
queryEncodePair s a =
case queryEncode s a of
QueryKeyAbsent -> Nothing
QueryKeyPresent -> Just (name, Nothing)
QueryKeyValued v -> Just (name, Just v)
where
name = fromString (withKnownSymbol s (symbolVal s))
instance QueryEncode s a => QueryEncode s (QueryKeyState a) where
queryEncode p v = v >>= queryEncode p
instance QueryEncode s Flag where
queryEncode _ Here = QueryKeyPresent
queryEncode _ NotHere = QueryKeyAbsent
instance QueryEncode s (Raw Text) where
queryEncode _ (Raw t) = QueryKeyValued t
instance QueryEncode s a => QueryEncode s (Maybe a) where
queryEncode _ Nothing = QueryKeyAbsent
queryEncode p (Just a) =
case queryEncode p a of
QueryKeyAbsent -> QueryKeyAbsent
QueryKeyPresent -> QueryKeyValued ""
QueryKeyValued txt -> QueryKeyValued txt
instance QueryDecode s a => QueryDecode s (QueryKeyState a) where
queryDecode p v =
case v of
QueryKeyAbsent -> Right QueryKeyAbsent
QueryKeyPresent -> Right QueryKeyPresent
QueryKeyValued _ ->
case queryDecode p v of
Left err -> Left err
Right val -> Right (QueryKeyValued val)
instance QueryDecode s Flag where
queryDecode _ QueryKeyAbsent = Right NotHere
queryDecode _ QueryKeyPresent = Right Here
queryDecode _ QueryKeyValued {} = Left "expected a flag query param, found a value"
instance QueryDecode s (Raw Text) where
queryDecode _ QueryKeyAbsent = Left "expected query key"
queryDecode _ QueryKeyPresent = Left "expected query value"
queryDecode _ (QueryKeyValued t) = Right (Raw t)
instance QueryDecode s a => QueryDecode s (Maybe a) where
queryDecode _ QueryKeyAbsent = Right Nothing
queryDecode p QueryKeyPresent = queryDecode p (QueryKeyValued "")
queryDecode p (QueryKeyValued t) = fmap Just (queryDecode p (QueryKeyValued t))