diff --git a/servant-foreign/src/Servant/Foreign.hs b/servant-foreign/src/Servant/Foreign.hs index 7aa2e2ba..5054e69f 100644 --- a/servant-foreign/src/Servant/Foreign.hs +++ b/servant-foreign/src/Servant/Foreign.hs @@ -37,274 +37,3 @@ module Servant.Foreign import Servant.API import Servant.Foreign.Internal -import Control.Lens (makeLenses, (%~), (&), (.~), (<>~)) -import qualified Data.Char as C -import Data.Monoid ((<>)) -import Data.Proxy -import Data.Text -import GHC.Exts (Constraint) -import GHC.TypeLits -import Prelude hiding (concat) -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 - | HeaderArgGen - { headerArgName :: Text - , headerArgGenBody :: (Text -> 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 :: 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 diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 27f0e411..706afd7a 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -20,12 +20,14 @@ module Servant.Foreign.Internal where import Control.Lens (makeLenses, (%~), (&), (.~), (<>~)) import qualified Data.Char as C +import Data.Monoid ((<>)) import Data.Proxy import Data.Text import GHC.Exts (Constraint) import GHC.TypeLits import Prelude hiding (concat) import Servant.API +import Servant.API.Authentication -- | Function name builder that simply concat each part together concatCase :: FunctionName -> Text @@ -74,7 +76,11 @@ data HeaderArg = HeaderArg | ReplaceHeaderArg { headerArg :: Arg , headerPattern :: Text - } deriving (Eq, Show) + } + | HeaderArgGen + { headerArgName :: Text + , headerArgGenBody :: (Text -> Text) + } data Url = Url @@ -95,7 +101,7 @@ data Req = Req , _reqBody :: Maybe ForeignType , _reqReturnType :: ForeignType , _funcName :: FunctionName - } deriving (Eq, Show) + } makeLenses ''QueryArg makeLenses ''Segment @@ -347,3 +353,26 @@ instance (GenerateList start, GenerateList rest) => GenerateList (start :<|> res listFromAPI :: (HasForeign lang api, GenerateList (Foreign api)) => Proxy lang -> Proxy api -> [Req] listFromAPI lang p = generateList (foreignFor lang p defReq) +instance (HasForeign lang sublayout) + => HasForeign lang ((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 lang) (Proxy :: Proxy sublayout) (req & reqHeaders <>~ + [HeaderArgGen "Authorization" ( \authdata -> + "(function("<>authdata<>"){" <> + "return \"Basic \" + btoa("<>authdata<>".username+\":\"+"<>authdata <> ".password)" <> + "})("<>authdata<>")") + ]) + +instance (HasForeign lang sublayout) + => HasForeign lang ((AuthProtect Text (usr :: *) (policy :: AuthPolicy) :> sublayout)) where + type Foreign (AuthProtect Text (usr :: *) (policy :: AuthPolicy) :> sublayout) = Foreign sublayout + + foreignFor _ Proxy req = + foreignFor (Proxy :: Proxy lang) (Proxy :: Proxy sublayout) (req & reqHeaders <>~ + [HeaderArgGen "Authorization" $ \authdata -> + "(function(" <> authdata <> "){" <> + "return \"Bearer \" + "<> authdata <> ";" <> + "})(" <> authdata<>")" + ])