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

{-# LANGUAGE CPP                   #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE NullaryTypeClasses    #-}
#endif
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE OverloadedStrings     #-}

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

import           Control.Lens (makeLenses, (%~), (&), (.~), (<>~))
import qualified Data.Char    as C
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
concatCase :: FunctionName -> Text
concatCase = concat

-- | Function name builder using the snake_case convention.
-- each part is separated by a single underscore character.
snakeCase :: FunctionName -> Text
snakeCase = intercalate "_"

-- | Function name builder using the CamelCase convention.
-- each part begins with an upper case character.
camelCase :: FunctionName -> Text
camelCase = camelCase' . Prelude.map (replace "-" "")
  where camelCase' []     = ""
        camelCase' (p:ps) = concat $ p : Prelude.map capitalize ps
        capitalize ""   = ""
        capitalize name = C.toUpper (Data.Text.head name) `cons` Data.Text.tail name

type ForeignType = Text
type Arg = (Text, ForeignType)

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

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
    { headerArg :: Arg
    }
  | ReplaceHeaderArg
    { headerArg :: Arg
    , headerPattern :: Text
    } deriving (Eq, Show)


data Url = Url
  { _path     :: Path
  , _queryStr :: [QueryArg]
  } deriving (Eq, Show)

defUrl :: Url
defUrl = Url [] []

type FunctionName = [Text]
type Method = Text

data Req = Req
  { _reqUrl        :: Url
  , _reqMethod     :: Method
  , _reqHeaders    :: [HeaderArg]
  , _reqBody       :: Maybe ForeignType
  , _reqReturnType :: ForeignType
  , _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" [] Nothing "" []

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

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 a, HasForeign lang sublayout)
      => HasForeign lang (Capture sym a :> 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)]
          & funcName %~ (++ ["by", str])

    where
    str = pack . symbolVal $ (Proxy :: Proxy sym)
    arg = (str, typeFor lang (Proxy :: Proxy a))

instance (Elem JSON list, HasForeignType lang a)
      => HasForeign lang (Delete list a) where
  type Foreign (Delete list a) = Req

  foreignFor lang Proxy req =
    req & funcName      %~ ("delete" :)
        & reqMethod     .~ "DELETE"
        & reqReturnType .~ retType
    where
    retType = typeFor lang (Proxy :: Proxy a)

instance (Elem JSON list, HasForeignType lang a)
      => HasForeign lang (Get list a) where
  type Foreign (Get list a) = Req

  foreignFor lang Proxy req =
    req & funcName  %~ ("get" :)
        & reqMethod .~ "GET"
        & reqReturnType .~ retType
    where
    retType = typeFor lang (Proxy :: Proxy a)

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 = (hname, typeFor lang (Proxy :: Proxy a))
    subP = Proxy :: Proxy sublayout

instance (Elem JSON list, HasForeignType lang a)
      => HasForeign lang (Post list a) where
  type Foreign (Post list a) = Req

  foreignFor lang Proxy req =
    req & funcName  %~ ("post" :)
        & reqMethod .~ "POST"
        & reqReturnType .~ retType
    where
    retType = typeFor lang (Proxy :: Proxy a)

instance (Elem JSON list, HasForeignType lang a)
      => HasForeign lang (Put list a) where
  type Foreign (Put list a) = Req

  foreignFor lang Proxy req =
    req & funcName  %~ ("put" :)
        & reqMethod .~ "PUT"
        & reqReturnType .~ retType
    where
    retType = typeFor lang (Proxy :: Proxy a)

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 = (str, 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 = (str, typeFor lang (Proxy :: Proxy a))

instance (KnownSymbol sym, HasForeignType lang a, a ~ 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 = (str, typeFor lang (Proxy :: Proxy a))

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

  foreignFor _ Proxy req method =
    req & funcName %~ ((toLower 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 str)]
          & funcName %~ (++ [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 (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)