mirror of
https://github.com/ilyakooo0/servant-reflex.git
synced 2024-09-11 07:15:29 +03:00
Add basicauth protected endpoint to example api server and client
This commit is contained in:
parent
bd6e66fe00
commit
810a32b22a
2
build.sh
2
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"
|
||||
|
2
deps/servant-snap
vendored
2
deps/servant-snap
vendored
@ -1 +1 @@
|
||||
Subproject commit bd1ffcbb3fbcbfe5ea9f7a96136975fb32cf6ae2
|
||||
Subproject commit 31acff4641c228fe5295388166bda485d583295d
|
@ -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] ()
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user