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

{-# LANGUAGE CPP #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE NullaryTypeClasses #-}
#endif

-- | Generalizes all the data needed to make code generation work with
-- arbitrary programming languages.
module Servant.Foreign.Internal where

import           Control.Lens hiding (cons)
import           Data.Proxy
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


newtype FunctionName = FunctionName { unFunctionName :: [Text] }
  deriving (Show, Eq, Monoid)

makePrisms ''FunctionName

newtype ForeignType = ForeignType { unForeignType :: Text }
  deriving (Show, Eq, IsString, Monoid)

makePrisms ''ForeignType

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
  = Static PathSegment
    -- ^ a static path segment. like "/foo"
  | Cap Arg
    -- ^ a capture. like "/:userid"
  deriving (Show, Eq)

makePrisms ''SegmentType

newtype Segment = Segment { unSegment :: SegmentType  }
  deriving (Eq, Show)

makePrisms ''Segment

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
  { _headerArg :: Arg }
  | ReplaceHeaderArg
  { _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
  , _reqMethod     :: HTTP.Method
  , _reqHeaders    :: [HeaderArg]
  , _reqBody       :: Maybe ForeignType
  , _reqReturnType :: ForeignType
  , _reqFuncName   :: FunctionName
  } deriving (Eq, Show)

makeLenses ''Req

defReq :: Req
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

-- | '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
-- >
--
class HasForeignType lang a where
  typeFor :: Proxy lang -> Proxy a -> ForeignType

data NoTypes

instance HasForeignType NoTypes ftype where
  typeFor _ _ = ForeignType empty

type HasNoForeignType = HasForeignType NoTypes

class HasForeign lang (layout :: *) where
  type Foreign layout :: *
  foreignFor :: Proxy lang -> Proxy layout -> Req -> Foreign layout

instance (HasForeign lang a, HasForeign lang b)
  => HasForeign lang (a :<|> b) where
  type Foreign (a :<|> b) = Foreign a :<|> Foreign b

  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

  foreignFor lang Proxy req =
    foreignFor lang (Proxy :: Proxy sublayout) $
      req & reqUrl . path <>~ [Segment (Cap arg)]
          & reqFuncName . _FunctionName %~ (++ ["by", str])
    where
      str   = pack . symbolVal $ (Proxy :: Proxy sym)
      ftype = typeFor lang (Proxy :: Proxy ftype)
      arg   = Arg
        { _aName = PathSegment str
        , _aType = ftype }

instance (Elem JSON list, HasForeignType lang a, ReflectMethod method)
  => HasForeign lang (Verb method status list a) where
  type Foreign (Verb method status list a) = Req

  foreignFor lang Proxy req =
    req & reqFuncName . _FunctionName %~ (methodLC :)
        & reqMethod .~ method
        & reqReturnType .~ retType
    where
      retType  = typeFor lang (Proxy :: Proxy a)
      method   = reflectMethod (Proxy :: Proxy method)
      methodLC = toLower $ decodeUtf8 method

instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
  => HasForeign lang (Header sym a :> sublayout) where
  type Foreign (Header sym a :> sublayout) = Foreign sublayout

  foreignFor lang Proxy req =
    foreignFor lang subP $ req & reqHeaders <>~ [HeaderArg arg]
    where
      hname = pack . symbolVal $ (Proxy :: Proxy sym)
      arg   = Arg
        { _aName = PathSegment hname
        , _aType  = typeFor lang (Proxy :: Proxy a) }
      subP  = Proxy :: Proxy sublayout

instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
  => HasForeign lang (QueryParam sym a :> sublayout) where
  type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout

  foreignFor lang Proxy req =
    foreignFor lang (Proxy :: Proxy sublayout) $
      req & reqUrl.queryStr <>~ [QueryArg arg Normal]
    where
      str = pack . symbolVal $ (Proxy :: Proxy sym)
      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
  foreignFor lang Proxy req =
    foreignFor lang (Proxy :: Proxy sublayout) $
      req & reqUrl.queryStr <>~ [QueryArg arg List]
    where
      str = pack . symbolVal $ (Proxy :: Proxy sym)
      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

  foreignFor lang Proxy req =
    foreignFor lang (Proxy :: Proxy sublayout) $
      req & reqUrl.queryStr <>~ [QueryArg arg Flag]
    where
      str = pack . symbolVal $ (Proxy :: Proxy sym)
      arg = Arg
        { _aName = PathSegment str
        , _aType = typeFor lang (Proxy :: Proxy Bool) }

instance HasForeign lang Raw where
  type Foreign Raw = HTTP.Method -> Req

  foreignFor _ Proxy req method =
    req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :)
        & reqMethod .~ method

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

  foreignFor lang Proxy req =
    foreignFor lang (Proxy :: Proxy sublayout) $
      req & reqBody .~ (Just $ typeFor lang (Proxy :: Proxy a))

instance (KnownSymbol path, HasForeign lang sublayout)
      => HasForeign lang (path :> sublayout) where
  type Foreign (path :> sublayout) = Foreign sublayout

  foreignFor lang Proxy req =
    foreignFor lang (Proxy :: Proxy sublayout) $
      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

  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

  foreignFor lang Proxy req =
    foreignFor lang (Proxy :: Proxy sublayout) req

instance HasForeign lang sublayout => HasForeign lang (Vault :> sublayout) where
  type Foreign (Vault :> sublayout) = Foreign sublayout

  foreignFor lang Proxy req =
    foreignFor lang (Proxy :: Proxy sublayout) req

instance HasForeign lang sublayout =>
  HasForeign lang (WithNamedContext name context sublayout) where

  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

  foreignFor lang Proxy req =
    foreignFor lang (Proxy :: Proxy sublayout) req

-- | 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
  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]
listFromAPI lang p = generateList (foreignFor lang p defReq)