810a32b · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

Add basicauth protected endpoint to example api server and client

commit810a32b22a624f1dbbc1fa2d9bbebb632696eb11 authorGreg Hale <imalsogreg@gmail.com> dateWed 20 Sep 2017, 13:57 (9 years ago) parentbd6e66f

7 files changed+43−16

compare with master

unifiedsplit

build.sh+1−1 deps/servant-snap+1−1 exec/API.hs+1 exec/Example.hs+22−4 servant-reflex.cabal+1−1 testserver/Main.hs+11−3 testserver/testserver.cabal+6−6

build.sh+1−1

@@ -1,3 +1,3 @@

11#!/usr/bin/env bash

3−deps/reflex-platform/work-on ./overrides.nix ./. --run "cabal configure --ghcjs && cabal build && exec/toSite.sh"

3+deps/reflex-platform/work-on ./overrides.nix ./. --run "cabal configure --ghcjs -f Example && cabal build && exec/toSite.sh"

deps/servant-snap+1−1

Submodule changed.

exec/API.hs+1

@@ -40,6 +40,7 @@ type API = "getunit" :> Get '[JSON] ()

4040 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text

4141 :<|> "qna" :> ReqBody '[JSON] Question

4242 :> Post '[JSON] Answer

43+ :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int

4344 :<|> Raw

4445

4546type GET = Get '[JSON] ()

exec/Example.hs+22−4

@@ -1,3 +1,4 @@

1+{-# LANGUAGE DataKinds #-}

12{-# LANGUAGE FlexibleContexts #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE OverloadedStrings #-}

@@ -14,6 +15,7 @@ import Control.Monad.Fix (MonadFix)

1415import Data.Monoid (First(..), (<>))

1516import Data.Text (Text)

1617import qualified Data.Text as T

18+import qualified Data.Text.Encoding as T

1719import GHC.TypeLits

1820import Servant.API

1921import API

@@ -43,7 +45,7 @@ runMulti :: forall t m. (SupportsServantReflex t m,

4345runMulti = do

4446 url <- baseUrlWidget

4547 el "br" blank

46− let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ ) =

48+ let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =

4749 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url

4850

4951 num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def

@@ -66,9 +68,12 @@ runMulti = do

6668 textInput def

6769 gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def

6870 b <- button "Go"

69− r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts) (constDyn [True, False]) (1 <$ b)

71+ r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts)

72+ (constDyn [True, False]) (1 <$ b)

73+

74+ dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes .

75+ fmap reqSuccess <$> r')

7076

71− dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes . fmap reqSuccess <$> r')

7277

7378 return ()

7479

@@ -91,7 +96,8 @@ run = mdo

9196 el "br" (return ())

9297

9398 -- Name the computed API client functions

99+ let (getUnit :<|> getInt :<|> sayhi :<|> dbl

100+ :<|> multi :<|> qna :<|> secret :<|> doRaw) =

95101 client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url

96102

97103 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now

@@ -177,6 +183,18 @@ run = mdo

177183 el "p" $

178184 dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)

179185

186+ divClass "demo-group" $ do

187+ un <- fmap value $ text "Username" >> textArea def

188+ pw <- fmap value $ text "Unhidden PW" >> textArea def

189+ let ba :: Dynamic t (BasicAuthData ) = BasicAuthData

190+ <$> fmap T.encodeUtf8 un

191+ <*> fmap T.encodeUtf8 pw

192+ b <- button "Get secret"

193+ r <- secret (Just <$> ba) (0 <$ b)

194+ res <- holdDyn Nothing (reqSuccess <$> r)

195+ display res

196+

197+

180198showXhrResponse :: XhrResponse -> Text

181199showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

182200 T.unlines ["stat: " <> tShow stat

servant-reflex.cabal+1−1

@@ -42,7 +42,7 @@ library

4242 reflex-dom == 0.4 && < 0.5,

4343 safe >= 0.3.9 && < 0.4,

4444 servant >= 0.8 && < 0.12,

45− servant-auth >= 0.2.7 && < 0.2.8,

45+ servant-auth >= 0.2.1 && < 0.3,

4646 string-conversions >= 0.4 && < 0.5,

4747 text >= 1.2 && < 1.3,

4848 transformers >= 0.4 && < 0.6

testserver/Main.hs+11−3

@@ -2,6 +2,7 @@

22{-# LANGUAGE DeriveGeneric #-}

33{-# LANGUAGE OverloadedStrings #-}

44{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE TypeApplications #-}

56{-# LANGUAGE TypeFamilies #-}

67{-# LANGUAGE TypeOperators #-}

@@ -47,8 +48,10 @@ data App = App

4748-- that represents the API, are glued together using :<|>.

4849--

4950-- Each handler runs in the 'ExceptT ServantErr IO' monad.

50−server :: Server API (Handler App App)

51+server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)

52+server = return () :<|> return 100 :<|> sayhi :<|> dbl

53+ :<|> multi :<|> qna :<|> serveSecret

54+ :<|> serveDirectory "static"

5255 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text

5356 sayhi nm greetings withGusto = case nm of

5457 Nothing -> return ("Sorry, who are you?" :: Text)

@@ -69,11 +72,16 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|>

6972 putStrLn $ "qna got: " ++ show q

7073 T.putStrLn $ unQuestion q

7174 return $ Answer $ unQuestion q

75+ serveSecret _ = do

76+ req <- getRequest

77+ liftIO $ putStrLn (show req)

78+ return 101

7279

7380-- Turn the server into a WAI app. 'serve' is provided by servant,

7481-- more precisely by the Servant.Server module.

7582test :: Handler App App ()

76−test = serveSnap testApi server

83+test = serveSnapWithContext testApi

84+ (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server

7785

7886initApp :: SnapletInit App App

7987initApp = makeSnaplet "myapp" "example" Nothing $ do

testserver/testserver.cabal+6−6

@@ -19,13 +19,13 @@ executable back

1919 main-is: Main.hs

2020 -- other-modules:

2121 -- other-extensions:

22− build-depends: aeson >= 0.9 && < 1.1

23− , base >=4.8 && <4.10

24− , snap >= 1.0 && < 1.1

22+ build-depends: aeson >= 0.9 && < 1.4

23+ , base >=4.8 && <4.11

24+ , snap >= 1.0 && < 1.2

2525 , snap-server >= 1.0 && < 1.1

2626 , snap-core >= 1.0 && < 1.1

27− , servant >= 0.8 && < 0.11

28− , servant-snap >= 0.7.2 && < 0.8

29− , text >= 1.2 && < 1.3

27+ , servant >= 0.8 && < 0.12

28+ , servant-snap >= 0.8 && < 0.9

29+ , text >= 1.0 && < 1.3

3030 -- hs-source-dirs:

3131 default-language: Haskell2010