servant/servant-foreign/src/Servant/Foreign.hs

288 lines
7.9 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
2015-09-23 20:39:46 +02:00
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE NullaryTypeClasses #-}
#endif
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
2015-10-02 10:23:57 +02:00
{-# LANGUAGE OverloadedStrings #-}
-- | Generalizes all the data needed to make code generation work with
-- arbitrary programming languages.
module Servant.Foreign
( HasForeign(..)
, Segment(..)
, SegmentType(..)
, FunctionName
, QueryArg(..)
, HeaderArg(..)
, ArgType(..)
, Req
, captureArg
, defReq
, concatCase
, snakeCase
, camelCase
-- lenses
, argType
, argName
, isCapture
, funcName
, path
, reqUrl
, reqBody
, reqHeaders
, reqMethod
, segment
, queryStr
-- re-exports
, module Servant.API
) where
import Control.Lens (makeLenses, (%~), (&), (.~), (<>~))
import Data.Proxy
import Data.Text
import GHC.Exts (Constraint)
import GHC.TypeLits
import Prelude hiding (concat)
import Servant.API
-- | Function name builder that simply concat each part together
2015-10-02 10:23:57 +02:00
concatCase :: FunctionName -> Text
concatCase = concat
-- | Function name builder using the snake_case convention.
-- each part is separated by a single underscore character.
2015-10-02 10:23:57 +02:00
snakeCase :: FunctionName -> Text
snakeCase = intercalate "_"
-- | Function name builder using the CamelCase convention.
-- each part begins with an upper case character.
2015-10-02 10:23:57 +02:00
camelCase :: FunctionName -> Text
camelCase [] = ""
camelCase (p:ps) = concat $ p : camelCase' ps
where camelCase' [] = []
2015-10-02 10:23:57 +02:00
camelCase' (r:rs) = toUpper r : camelCase' rs
2015-10-02 10:23:57 +02:00
type Arg = Text
newtype Segment = Segment { _segment :: SegmentType }
deriving (Eq, Show)
2015-10-02 10:23:57 +02:00
data SegmentType = Static Text -- ^ a static path segment. like "/foo"
| Cap Arg -- ^ a capture. like "/:userid"
deriving (Eq, Show)
type Path = [Segment]
data ArgType =
Normal
| Flag
| List
deriving (Eq, Show)
data QueryArg = QueryArg
{ _argName :: Arg
, _argType :: ArgType
} deriving (Eq, Show)
data HeaderArg = HeaderArg
2015-10-02 10:23:57 +02:00
{ headerArgName :: Text
}
| ReplaceHeaderArg
2015-10-02 10:23:57 +02:00
{ headerArgName :: Text
, headerPattern :: Text
} deriving (Eq, Show)
data Url = Url
{ _path :: Path
, _queryStr :: [QueryArg]
} deriving (Eq, Show)
defUrl :: Url
defUrl = Url [] []
2015-10-02 10:23:57 +02:00
type FunctionName = [Text]
type Method = Text
data Req = Req
{ _reqUrl :: Url
, _reqMethod :: Method
, _reqHeaders :: [HeaderArg]
, _reqBody :: Bool
, _funcName :: FunctionName
} deriving (Eq, Show)
makeLenses ''QueryArg
makeLenses ''Segment
makeLenses ''Url
makeLenses ''Req
isCapture :: Segment -> Bool
isCapture (Segment (Cap _)) = True
isCapture _ = False
captureArg :: Segment -> Arg
captureArg (Segment (Cap s)) = s
captureArg _ = error "captureArg called on non capture"
defReq :: Req
defReq = Req defUrl "GET" [] False []
-- | To be used exclusively as a "negative" return type/constraint
-- by @'Elem`@ type family.
class NotFound
type family Elem (a :: *) (ls::[*]) :: Constraint where
Elem a '[] = NotFound
Elem a (a ': list) = ()
Elem a (b ': list) = Elem a list
class HasForeign (layout :: *) where
type Foreign layout :: *
foreignFor :: Proxy layout -> Req -> Foreign layout
instance (HasForeign a, HasForeign b)
=> HasForeign (a :<|> b) where
type Foreign (a :<|> b) = Foreign a :<|> Foreign b
foreignFor Proxy req =
foreignFor (Proxy :: Proxy a) req
:<|> foreignFor (Proxy :: Proxy b) req
instance (KnownSymbol sym, HasForeign sublayout)
=> HasForeign (Capture sym a :> sublayout) where
type Foreign (Capture sym a :> sublayout) = Foreign sublayout
foreignFor Proxy req =
foreignFor (Proxy :: Proxy sublayout) $
req & reqUrl.path <>~ [Segment (Cap str)]
& funcName %~ (++ ["by", str])
2015-10-02 10:23:57 +02:00
where str = pack . symbolVal $ (Proxy :: Proxy sym)
instance Elem JSON list => HasForeign (Delete list a) where
type Foreign (Delete list a) = Req
foreignFor Proxy req =
req & funcName %~ ("delete" :)
& reqMethod .~ "DELETE"
instance Elem JSON list => HasForeign (Get list a) where
type Foreign (Get list a) = Req
foreignFor Proxy req =
req & funcName %~ ("get" :)
& reqMethod .~ "GET"
instance (KnownSymbol sym, HasForeign sublayout)
=> HasForeign (Header sym a :> sublayout) where
type Foreign (Header sym a :> sublayout) = Foreign sublayout
foreignFor Proxy req =
foreignFor subP (req & reqHeaders <>~ [HeaderArg hname])
2015-10-02 10:23:57 +02:00
where hname = pack . symbolVal $ (Proxy :: Proxy sym)
subP = Proxy :: Proxy sublayout
instance Elem JSON list => HasForeign (Post list a) where
type Foreign (Post list a) = Req
foreignFor Proxy req =
req & funcName %~ ("post" :)
& reqMethod .~ "POST"
instance Elem JSON list => HasForeign (Put list a) where
type Foreign (Put list a) = Req
foreignFor Proxy req =
req & funcName %~ ("put" :)
& reqMethod .~ "PUT"
instance (KnownSymbol sym, HasForeign sublayout)
=> HasForeign (QueryParam sym a :> sublayout) where
type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout
foreignFor Proxy req =
foreignFor (Proxy :: Proxy sublayout) $
req & reqUrl.queryStr <>~ [QueryArg str Normal]
2015-10-02 10:23:57 +02:00
where str = pack . symbolVal $ (Proxy :: Proxy sym)
instance (KnownSymbol sym, HasForeign sublayout)
=> HasForeign (QueryParams sym a :> sublayout) where
type Foreign (QueryParams sym a :> sublayout) = Foreign sublayout
foreignFor Proxy req =
foreignFor (Proxy :: Proxy sublayout) $
req & reqUrl.queryStr <>~ [QueryArg str List]
2015-10-02 10:23:57 +02:00
where str = pack . symbolVal $ (Proxy :: Proxy sym)
instance (KnownSymbol sym, HasForeign sublayout)
=> HasForeign (QueryFlag sym :> sublayout) where
type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout
foreignFor Proxy req =
foreignFor (Proxy :: Proxy sublayout) $
req & reqUrl.queryStr <>~ [QueryArg str Flag]
2015-10-02 10:23:57 +02:00
where str = pack . symbolVal $ (Proxy :: Proxy sym)
instance HasForeign Raw where
type Foreign Raw = Method -> Req
foreignFor Proxy req method =
2015-10-02 10:23:57 +02:00
req & funcName %~ ((toLower method) :)
& reqMethod .~ method
instance (Elem JSON list, HasForeign sublayout) => HasForeign (ReqBody list a :> sublayout) where
type Foreign (ReqBody list a :> sublayout) = Foreign sublayout
foreignFor Proxy req =
foreignFor (Proxy :: Proxy sublayout) $
req & reqBody .~ True
instance (KnownSymbol path, HasForeign sublayout)
=> HasForeign (path :> sublayout) where
type Foreign (path :> sublayout) = Foreign sublayout
foreignFor Proxy req =
foreignFor (Proxy :: Proxy sublayout) $
req & reqUrl.path <>~ [Segment (Static str)]
& funcName %~ (++ [str])
2015-10-02 10:23:57 +02:00
where str = Data.Text.map (\c -> if c == '.' then '_' else c) . pack . symbolVal $ (Proxy :: Proxy path)
instance HasForeign sublayout => HasForeign (RemoteHost :> sublayout) where
type Foreign (RemoteHost :> sublayout) = Foreign sublayout
foreignFor Proxy req =
foreignFor (Proxy :: Proxy sublayout) req
instance HasForeign sublayout => HasForeign (IsSecure :> sublayout) where
type Foreign (IsSecure :> sublayout) = Foreign sublayout
foreignFor Proxy req =
foreignFor (Proxy :: Proxy sublayout) req
instance HasForeign sublayout => HasForeign (Vault :> sublayout) where
type Foreign (Vault :> sublayout) = Foreign sublayout
foreignFor Proxy req =
foreignFor (Proxy :: Proxy sublayout) req
instance HasForeign sublayout => HasForeign (HttpVersion :> sublayout) where
type Foreign (HttpVersion :> sublayout) = Foreign sublayout
foreignFor Proxy req =
foreignFor (Proxy :: Proxy sublayout) req