diff --git a/servant-foreign/src/Servant/Foreign.hs b/servant-foreign/src/Servant/Foreign.hs index 5054e69f..a27cbbb7 100644 --- a/servant-foreign/src/Servant/Foreign.hs +++ b/servant-foreign/src/Servant/Foreign.hs @@ -37,3 +37,275 @@ module Servant.Foreign import Servant.API import Servant.Foreign.Internal +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 +import Servant.API +import Servant.API.Authentication + +-- | 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 Arg = Text + +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 + { headerArgName :: Text + } + | ReplaceHeaderArg + { headerArgName :: Text + , headerPattern :: Text + } deriving (Eq, Show) + | HeaderArgGen + { headerArgName :: String + , headerArgGenBody :: (String -> String) + } + + +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 :: Bool + , _funcName :: FunctionName + } + +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]) + + 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]) + + where hname = pack . symbolVal $ (Proxy :: Proxy sym) + subP = Proxy :: Proxy sublayout + +instance (HasForeign sublayout) + => HasForeign (AuthProtect (BasicAuth realm) (usr :: *) (policy :: AuthPolicy) :> sublayout) where + type Foreign (AuthProtect (BasicAuth realm) (usr :: *) (policy :: AuthPolicy) :> sublayout) = Foreign sublayout + + foreignFor Proxy req = + foreignFor (Proxy :: Proxy sublayout) (req & reqHeaders <>~ + [HeaderArgGen "Authorization" $ \authdata -> + "(function("++authdata++"){" ++ + "return \"Basic \" + btoa("++authdata++".username+\":\"+"++authdata ++ ".password)" ++ + "})("++authdata++")" + ]) + +instance (HasForeign sublayout) + => HasForeign (AuthProtect Text (usr :: *) (policy :: AuthPolicy) :> sublayout) where + type Foreign (AuthProtect Text (usr :: *) (policy :: AuthPolicy) :> sublayout) = Foreign sublayout + + foreignFor Proxy req = + foreignFor (Proxy :: Proxy sublayout) (req & reqHeaders <>~ + [HeaderArgGen "Authorization" $ \authdata -> + "(function("++authdata++"){" ++ + "return \"Bearer \" + "++authdata++";"++ + "})("++authdata++")" + ]) + +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] + + 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] + + 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] + + where str = pack . symbolVal $ (Proxy :: Proxy sym) + +instance HasForeign Raw where + type Foreign Raw = Method -> Req + + foreignFor Proxy req method = + 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]) + + 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 +>>>>>>> 29b4dd5... Add support for authentication to servant-foreign and servant-js