Add basicauth protected endpoint to example api server and client

build.sh

@@ -1,3 +1,3 @@
 #!/usr/bin/env bash
 
-deps/reflex-platform/work-on ./overrides.nix ./. --run "cabal configure --ghcjs && cabal build && exec/toSite.sh"
+deps/reflex-platform/work-on ./overrides.nix ./. --run "cabal configure --ghcjs -f Example && cabal build && exec/toSite.sh"

deps/servant-snap

@@ -1 +1 @@
-Subproject commit bd1ffcbb3fbcbfe5ea9f7a96136975fb32cf6ae2
+Subproject commit 31acff4641c228fe5295388166bda485d583295d

exec/API.hs

@@ -40,6 +40,7 @@ type API = "getunit" :> Get '[JSON] ()
       :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
       :<|> "qna" :> ReqBody '[JSON] Question
                  :> Post '[JSON] Answer
+      :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
       :<|> Raw
 
 type GET = Get '[JSON] ()

exec/Example.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE GADTs               #-}
 {-# LANGUAGE OverloadedStrings   #-}
@@ -14,6 +15,7 @@ import Control.Monad.Fix (MonadFix)
 import Data.Monoid (First(..), (<>))
 import Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
 import GHC.TypeLits
 import Servant.API
 import API
@@ -43,7 +45,7 @@ runMulti :: forall t m. (SupportsServantReflex t m,
 runMulti = do
     url <- baseUrlWidget
     el "br" blank
-    let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ ) =
+    let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =
             clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
 
     num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
@@ -66,9 +68,12 @@ runMulti = do
             textInput def
         gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def
         b <- button "Go"
-        r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts) (constDyn [True, False]) (1 <$ b)
+        r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts)
+                    (constDyn [True, False]) (1 <$ b)
+
+        dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes .
+                                       fmap reqSuccess  <$> r')
 
-        dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes . fmap reqSuccess  <$> r')
 
     return ()
 
@@ -91,7 +96,8 @@ run = mdo
   el "br" (return ())
 
   -- Name the computed API client functions
-  let (getUnit :<|> getInt :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> doRaw) =
+  let (getUnit :<|> getInt :<|> sayhi :<|> dbl
+       :<|> multi :<|> qna :<|> secret :<|> doRaw) =
         client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url
 
       c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
@@ -177,6 +183,18 @@ run = mdo
     el "p" $
       dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
 
+  divClass "demo-group" $ do
+    un <- fmap value $ text "Username"    >> textArea def
+    pw <- fmap value $ text "Unhidden PW" >> textArea def
+    let ba :: Dynamic t (BasicAuthData ) = BasicAuthData
+                                           <$> fmap T.encodeUtf8 un
+                                           <*> fmap T.encodeUtf8 pw
+    b <- button "Get secret"
+    r  <- secret (Just <$> ba) (0 <$ b)
+    res <- holdDyn Nothing (reqSuccess <$> r)
+    display res
+
+
 showXhrResponse :: XhrResponse -> Text
 showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
   T.unlines ["stat: " <> tShow stat

servant-reflex.cabal

@@ -42,7 +42,7 @@ library
     reflex-dom          == 0.4  && < 0.5,
     safe                >= 0.3.9 && < 0.4,
     servant             >= 0.8  && < 0.12,
-    servant-auth        >= 0.2.7 && < 0.2.8,
+    servant-auth        >= 0.2.1 && < 0.3,
     string-conversions  >= 0.4  && < 0.5,
     text                >= 1.2  && < 1.3,
     transformers        >= 0.4  && < 0.6

testserver/Main.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PolyKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE TypeFamilies      #-}
 {-# LANGUAGE TypeOperators     #-}
 
@@ -47,8 +48,10 @@ data App = App
 -- that represents the API, are glued together using :<|>.
 --
 -- Each handler runs in the 'ExceptT ServantErr IO' monad.
-server :: Server API (Handler App App)
-server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> serveDirectory "static"
+server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)
+server = return () :<|> return 100 :<|> sayhi :<|> dbl
+    :<|> multi :<|> qna :<|> serveSecret
+    :<|> serveDirectory "static"
   where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
         sayhi nm greetings withGusto = case nm of
           Nothing -> return ("Sorry, who are you?" :: Text)
@@ -69,11 +72,16 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|>
             putStrLn $ "qna got: " ++ show q
             T.putStrLn $ unQuestion q
           return $ Answer $ unQuestion q
+        serveSecret _ = do
+          req <- getRequest
+          liftIO $ putStrLn (show req)
+          return 101
 
 -- Turn the server into a WAI app. 'serve' is provided by servant,
 -- more precisely by the Servant.Server module.
 test :: Handler App App ()
-test = serveSnap testApi server
+test = serveSnapWithContext testApi
+       (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server
 
 initApp :: SnapletInit App App
 initApp = makeSnaplet "myapp" "example" Nothing $ do

testserver/testserver.cabal

@@ -19,13 +19,13 @@ executable back
   main-is:             Main.hs
   -- other-modules:
   -- other-extensions:
-  build-depends:       aeson >= 0.9 && < 1.1
-                     , base >=4.8 && <4.10
-                     , snap >= 1.0 && < 1.1
+  build-depends:       aeson >= 0.9 && < 1.4
+                     , base >=4.8 && <4.11
+                     , snap >= 1.0 && < 1.2
                      , snap-server  >= 1.0 && < 1.1
                      , snap-core  >= 1.0 && < 1.1
-                     , servant >= 0.8 && < 0.11
-                     , servant-snap >= 0.7.2 && < 0.8
-                     , text  >= 1.2 && < 1.3
+                     , servant >= 0.8 && < 0.12
+                     , servant-snap >= 0.8 && < 0.9
+                     , text  >= 1.0 && < 1.3
   -- hs-source-dirs:
   default-language:    Haskell2010