From 81f48c6b1461ee73ecbff5c9c564b136926f919f Mon Sep 17 00:00:00 2001
From: Arian van Putten <aeroboy94@gmail.com>
Date: Sat, 3 Oct 2015 00:11:11 +0200
Subject: [PATCH] Add support for authentication to servant-foreign and
 servant-js

---
 servant-foreign/servant-foreign.cabal  |  3 ++-
 servant-foreign/src/Servant/Foreign.hs | 35 +++++++++++++++++++++++---
 servant-js/src/Servant/JS/Internal.hs  |  1 +
 3 files changed, 35 insertions(+), 4 deletions(-)

diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal
index 90ebe8bb..372a5081 100644
--- a/servant-foreign/servant-foreign.cabal
+++ b/servant-foreign/servant-foreign.cabal
@@ -29,6 +29,7 @@ library
   build-depends:       base    == 4.*
                      , lens    == 4.*
                      , servant == 0.5.*
+                     , text            >= 1.2  && < 1.3
   hs-source-dirs:      src
   default-language:    Haskell2010
-  ghc-options:         -Wall
\ No newline at end of file
+  ghc-options:         -Wall
diff --git a/servant-foreign/src/Servant/Foreign.hs b/servant-foreign/src/Servant/Foreign.hs
index 6cd72b84..2c4f9dec 100644
--- a/servant-foreign/src/Servant/Foreign.hs
+++ b/servant-foreign/src/Servant/Foreign.hs
@@ -54,10 +54,11 @@ import           Control.Lens                  (makeLenses, (%~), (&), (.~),
 import Data.Char (toLower, toUpper)
 import Data.List
 import Data.Proxy
+import Data.Text (Text)
 import GHC.Exts (Constraint)
 import GHC.TypeLits
 import Servant.API
-
+import Servant.API.Authentication
 -- | Function name builder that simply concat each part together
 concatCase :: FunctionName -> String
 concatCase = concat
@@ -105,7 +106,11 @@ data HeaderArg = HeaderArg
   | ReplaceHeaderArg
     { headerArgName :: String
     , headerPattern :: String
-    } deriving (Eq, Show)
+    }
+  | HeaderArgGen
+    { headerArgName    :: String
+    , headerArgGenBody :: (String -> String)
+    }
 
 
 type MatrixArg = QueryArg
@@ -127,7 +132,7 @@ data Req = Req
   , _reqHeaders :: [HeaderArg]
   , _reqBody    :: Bool
   , _funcName   :: FunctionName
-  } deriving (Eq, Show)
+  }
 
 makeLenses ''QueryArg
 makeLenses ''Segment
@@ -201,6 +206,30 @@ instance (KnownSymbol sym, HasForeign sublayout)
     where hname = 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
 
diff --git a/servant-js/src/Servant/JS/Internal.hs b/servant-js/src/Servant/JS/Internal.hs
index a7af966b..473c72a9 100644
--- a/servant-js/src/Servant/JS/Internal.hs
+++ b/servant-js/src/Servant/JS/Internal.hs
@@ -111,6 +111,7 @@ toValidFunctionName [] = "_"
 
 toJSHeader :: HeaderArg -> String
 toJSHeader (HeaderArg n)          = toValidFunctionName ("header" <> n)
+toJSHeader (HeaderArgGen n b)     = b (toJSHeader (HeaderArg n))
 toJSHeader (ReplaceHeaderArg n p)
   | pn `isPrefixOf` p = pv <> " + \"" <> rp <> "\""
   | pn `isSuffixOf` p = "\"" <> rp <> "\" + " <> pv