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

346 lines
10 KiB
Haskell
Raw Normal View History

2016-02-17 22:47:30 +01:00
{-# LANGUAGE CPP #-}
2015-09-23 20:39:46 +02:00
#if !MIN_VERSION_base(4,8,0)
2016-02-17 22:47:30 +01:00
{-# LANGUAGE NullaryTypeClasses #-}
2015-09-23 20:39:46 +02:00
#endif
-- | Generalizes all the data needed to make code generation work with
-- arbitrary programming languages.
2015-11-16 18:40:15 +01:00
module Servant.Foreign.Internal where
2016-02-17 22:47:30 +01:00
import Control.Lens hiding (cons)
import Data.Proxy
2016-02-17 22:47:30 +01:00
import Data.String
import Data.Text
import Data.Text.Encoding (decodeUtf8)
import GHC.Exts (Constraint)
import GHC.TypeLits
import qualified Network.HTTP.Types as HTTP
import Prelude hiding (concat)
import Servant.API
2016-02-17 22:47:30 +01:00
newtype FunctionName = FunctionName { unFunctionName :: [Text] }
deriving (Show, Eq, Monoid)
2016-02-17 22:47:30 +01:00
makePrisms ''FunctionName
2016-02-17 22:47:30 +01:00
newtype ForeignType = ForeignType { unForeignType :: Text }
deriving (Show, Eq, IsString, Monoid)
2016-02-17 22:47:30 +01:00
makePrisms ''ForeignType
2016-02-17 22:47:30 +01:00
newtype PathSegment = PathSegment { unPathSegment :: Text }
deriving (Show, Eq, IsString, Monoid)
makePrisms ''PathSegment
data Arg = Arg
{ _aName :: PathSegment
, _aType :: ForeignType }
deriving (Show, Eq)
makeLenses ''Arg
aPath :: Getter Arg Text
aPath = aName . _PathSegment
data SegmentType
2016-02-17 22:47:30 +01:00
= Static PathSegment
-- ^ a static path segment. like "/foo"
| Cap Arg
-- ^ a capture. like "/:userid"
2016-02-17 22:47:30 +01:00
deriving (Show, Eq)
makePrisms ''SegmentType
newtype Segment = Segment { unSegment :: SegmentType }
deriving (Eq, Show)
makePrisms ''Segment
2016-02-17 22:47:30 +01:00
isCapture :: Segment -> Bool
isCapture (Segment (Cap _)) = True
isCapture _ = False
captureArg :: Segment -> Arg
captureArg (Segment (Cap s)) = s
captureArg _ = error "captureArg called on non capture"
type Path = [Segment]
data ArgType
= Normal
| Flag
| List
deriving (Eq, Show)
makePrisms ''ArgType
data QueryArg = QueryArg
{ _argName :: Arg
, _argType :: ArgType
} deriving (Eq, Show)
makeLenses ''QueryArg
data HeaderArg = HeaderArg
2016-02-17 22:47:30 +01:00
{ _headerArg :: Arg }
| ReplaceHeaderArg
2016-02-17 22:47:30 +01:00
{ _headerArg :: Arg
, _headerPattern :: Text
} deriving (Eq, Show)
makeLenses ''HeaderArg
makePrisms ''HeaderArg
data Url = Url
{ _path :: Path
, _queryStr :: [QueryArg]
} deriving (Eq, Show)
defUrl :: Url
defUrl = Url [] []
makeLenses ''Url
data Req = Req
{ _reqUrl :: Url
2016-01-06 18:20:20 +01:00
, _reqMethod :: HTTP.Method
, _reqHeaders :: [HeaderArg]
, _reqBody :: Maybe ForeignType
, _reqReturnType :: ForeignType
, _reqFuncName :: FunctionName
} deriving (Eq, Show)
makeLenses ''Req
defReq :: Req
2016-02-17 22:47:30 +01:00
defReq = Req defUrl "GET" [] Nothing (ForeignType "") (FunctionName [])
-- | 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
2015-12-02 15:10:30 +01:00
-- | 'HasForeignType' maps Haskell types with types in the target
-- language of your backend. For example, let's say you're
-- implementing a backend to some language __X__:
--
-- > -- First you need to create a dummy type to parametrize your
-- > -- instances.
-- > data LangX
-- >
-- > -- Otherwise you define instances for the types you need
-- > instance HasForeignType LangX Int where
-- > typeFor _ _ = "intX"
-- >
-- > -- Or for example in case of lists
-- > instance HasForeignType LangX a => HasForeignType LangX [a] where
-- > typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a)
--
-- Finally to generate list of information about all the endpoints for
-- an API you create a function of a form:
--
-- > getEndpoints :: (HasForeign LangX api, GenerateList (Foreign api))
-- > => Proxy api -> [Req]
-- > getEndpoints api = listFromAPI (Proxy :: Proxy LangX) api
--
-- > -- If language __X__ is dynamically typed then you can use
-- > -- a predefined NoTypes parameter
-- > getEndpoints :: (HasForeign NoTypes api, GenerateList (Foreign api))
-- > => Proxy api -> [Req]
-- > getEndpoints api = listFromAPI (Proxy :: Proxy NoTypes) api
-- >
--
2015-11-29 05:53:50 +01:00
class HasForeignType lang a where
typeFor :: Proxy lang -> Proxy a -> ForeignType
data NoTypes
instance HasForeignType NoTypes ftype where
2016-02-17 22:47:30 +01:00
typeFor _ _ = ForeignType empty
type HasNoForeignType = HasForeignType NoTypes
2015-11-29 05:53:50 +01:00
class HasForeign lang (layout :: *) where
type Foreign layout :: *
2015-11-29 05:53:50 +01:00
foreignFor :: Proxy lang -> Proxy layout -> Req -> Foreign layout
2015-11-29 05:53:50 +01:00
instance (HasForeign lang a, HasForeign lang b)
=> HasForeign lang (a :<|> b) where
type Foreign (a :<|> b) = Foreign a :<|> Foreign b
2015-11-29 05:53:50 +01:00
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy a) req
:<|> foreignFor lang (Proxy :: Proxy b) req
instance (KnownSymbol sym, HasForeignType lang ftype, HasForeign lang sublayout)
=> HasForeign lang (Capture sym ftype :> sublayout) where
type Foreign (Capture sym a :> sublayout) = Foreign sublayout
2015-11-29 05:53:50 +01:00
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $
2016-02-17 22:47:30 +01:00
req & reqUrl . path <>~ [Segment (Cap arg)]
& reqFuncName . _FunctionName %~ (++ ["by", str])
where
2016-02-17 22:47:30 +01:00
str = pack . symbolVal $ (Proxy :: Proxy sym)
ftype = typeFor lang (Proxy :: Proxy ftype)
arg = Arg
{ _aName = PathSegment str
, _aType = ftype }
2016-01-06 18:20:20 +01:00
instance (Elem JSON list, HasForeignType lang a, ReflectMethod method)
=> HasForeign lang (Verb method status list a) where
2016-01-06 18:20:20 +01:00
type Foreign (Verb method status list a) = Req
2015-11-29 05:53:50 +01:00
foreignFor lang Proxy req =
2016-02-17 22:47:30 +01:00
req & reqFuncName . _FunctionName %~ (methodLC :)
2016-01-06 18:20:20 +01:00
& reqMethod .~ method
& reqReturnType .~ retType
where
retType = typeFor lang (Proxy :: Proxy a)
method = reflectMethod (Proxy :: Proxy method)
methodLC = toLower $ decodeUtf8 method
2015-11-29 05:53:50 +01:00
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
=> HasForeign lang (Header sym a :> sublayout) where
type Foreign (Header sym a :> sublayout) = Foreign sublayout
2015-11-29 05:53:50 +01:00
foreignFor lang Proxy req =
2016-02-17 22:47:30 +01:00
foreignFor lang subP $ req & reqHeaders <>~ [HeaderArg arg]
where
hname = pack . symbolVal $ (Proxy :: Proxy sym)
2016-02-17 22:47:30 +01:00
arg = Arg
{ _aName = PathSegment hname
, _aType = typeFor lang (Proxy :: Proxy a) }
subP = Proxy :: Proxy sublayout
2015-11-29 05:53:50 +01:00
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
=> HasForeign lang (QueryParam sym a :> sublayout) where
type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout
2015-11-29 05:53:50 +01:00
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $
req & reqUrl.queryStr <>~ [QueryArg arg Normal]
where
str = pack . symbolVal $ (Proxy :: Proxy sym)
2016-02-17 22:47:30 +01:00
arg = Arg
{ _aName = PathSegment str
, _aType = typeFor lang (Proxy :: Proxy a) }
instance
(KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout)
=> HasForeign lang (QueryParams sym a :> sublayout) where
type Foreign (QueryParams sym a :> sublayout) = Foreign sublayout
2015-11-29 05:53:50 +01:00
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $
req & reqUrl.queryStr <>~ [QueryArg arg List]
where
str = pack . symbolVal $ (Proxy :: Proxy sym)
2016-02-17 22:47:30 +01:00
arg = Arg
{ _aName = PathSegment str
, _aType = typeFor lang (Proxy :: Proxy [a]) }
instance
(KnownSymbol sym, HasForeignType lang Bool, HasForeign lang sublayout)
=> HasForeign lang (QueryFlag sym :> sublayout) where
type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout
2015-11-29 05:53:50 +01:00
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $
req & reqUrl.queryStr <>~ [QueryArg arg Flag]
where
str = pack . symbolVal $ (Proxy :: Proxy sym)
2016-02-17 22:47:30 +01:00
arg = Arg
{ _aName = PathSegment str
, _aType = typeFor lang (Proxy :: Proxy Bool) }
2015-11-29 05:53:50 +01:00
instance HasForeign lang Raw where
2016-01-06 18:20:20 +01:00
type Foreign Raw = HTTP.Method -> Req
2015-11-29 05:53:50 +01:00
foreignFor _ Proxy req method =
2016-02-17 22:47:30 +01:00
req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :)
& reqMethod .~ method
2015-11-29 05:53:50 +01:00
instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout)
=> HasForeign lang (ReqBody list a :> sublayout) where
type Foreign (ReqBody list a :> sublayout) = Foreign sublayout
2015-11-29 05:53:50 +01:00
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $
req & reqBody .~ (Just $ typeFor lang (Proxy :: Proxy a))
2015-11-29 05:53:50 +01:00
instance (KnownSymbol path, HasForeign lang sublayout)
=> HasForeign lang (path :> sublayout) where
type Foreign (path :> sublayout) = Foreign sublayout
2015-11-29 05:53:50 +01:00
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $
2016-02-17 22:47:30 +01:00
req & reqUrl . path <>~ [Segment (Static (PathSegment str))]
& reqFuncName . _FunctionName %~ (++ [str])
where
str =
Data.Text.map (\c -> if c == '.' then '_' else c)
. pack . symbolVal $ (Proxy :: Proxy path)
instance HasForeign lang sublayout
=> HasForeign lang (RemoteHost :> sublayout) where
type Foreign (RemoteHost :> sublayout) = Foreign sublayout
2015-11-29 05:53:50 +01:00
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) req
instance HasForeign lang sublayout
=> HasForeign lang (IsSecure :> sublayout) where
type Foreign (IsSecure :> sublayout) = Foreign sublayout
2015-11-29 05:53:50 +01:00
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) req
2015-11-29 05:53:50 +01:00
instance HasForeign lang sublayout => HasForeign lang (Vault :> sublayout) where
type Foreign (Vault :> sublayout) = Foreign sublayout
2015-11-29 05:53:50 +01:00
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) req
instance HasForeign lang sublayout =>
2016-02-28 23:23:32 +01:00
HasForeign lang (WithNamedContext name context sublayout) where
2016-02-28 23:23:32 +01:00
type Foreign (WithNamedContext name context sublayout) = Foreign sublayout
foreignFor lang Proxy = foreignFor lang (Proxy :: Proxy sublayout)
instance HasForeign lang sublayout
=> HasForeign lang (HttpVersion :> sublayout) where
type Foreign (HttpVersion :> sublayout) = Foreign sublayout
2015-11-29 05:53:50 +01:00
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) req
2015-12-02 12:21:37 +01:00
-- | Utility class used by 'listFromAPI' which computes
-- the data needed to generate a function for each endpoint
-- and hands it all back in a list.
class GenerateList reqs where
generateList :: reqs -> [Req]
instance GenerateList Req where
generateList r = [r]
instance (GenerateList start, GenerateList rest)
=> GenerateList (start :<|> rest) where
2015-12-02 12:21:37 +01:00
generateList (start :<|> rest) = (generateList start) ++ (generateList rest)
-- | Generate the necessary data for codegen as a list, each 'Req'
-- describing one endpoint from your API type.
listFromAPI
:: (HasForeign lang api, GenerateList (Foreign api))
=> Proxy lang
-> Proxy api
-> [Req]
2015-12-02 12:21:37 +01:00
listFromAPI lang p = generateList (foreignFor lang p defReq)