Implement basic auth on server

This commit is contained in:
Rene Vergara 2024-07-24 16:03:49 -05:00
parent b66d0d9563
commit cbcf7c9c8c
Signed by: pitmutt
GPG key ID: 65122AD495A7F5B2
2 changed files with 50 additions and 7 deletions

View file

@ -1,8 +1,23 @@
{-# LANGUAGE OverloadedStrings #-}
module Server where module Server where
import Data.Configurator
import Network.Wai.Handler.Warp (run) import Network.Wai.Handler.Warp (run)
import Servant import Servant
import Zenith.RPC (ZenithRPC(..), zenithServer) import Zenith.RPC (ZenithRPC(..), authenticate, zenithServer)
import Zenith.Types (Config(..))
main :: IO () main :: IO ()
main = run 8081 (serve (Proxy :: Proxy ZenithRPC) zenithServer) main = do
config <- load ["$(HOME)/Zenith/zenith.cfg"]
dbFilePath <- require config "dbFilePath"
nodeUser <- require config "nodeUser"
nodePwd <- require config "nodePwd"
zebraPort <- require config "zebraPort"
zebraHost <- require config "zebraHost"
nodePort <- require config "nodePort"
let myConfig = Config dbFilePath zebraHost zebraPort nodeUser nodePwd nodePort
let ctx = authenticate myConfig :. EmptyContext
run 8081 $
serveWithContext (Proxy :: Proxy ZenithRPC) ctx (zenithServer myConfig)

View file

@ -1,22 +1,36 @@
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Zenith.RPC where module Zenith.RPC where
import Data.Aeson import Data.Aeson
import qualified Data.Text as T import qualified Data.Text as T
import Data.Typeable
import GHC.Generics (Generic)
import Servant import Servant
import ZcashHaskell.Types (RpcError(..), RpcResponse(..)) import ZcashHaskell.Types (RpcError(..), RpcResponse(..))
import Zenith.Types (RpcCall(..), ZenithMethod(..), ZenithParams(..)) import Zenith.Types
( Config(..)
, RpcCall(..)
, ZenithMethod(..)
, ZenithParams(..)
)
type ZenithRPC type ZenithRPC
= "getinfo" :> Get '[ JSON] Value :<|> ReqBody '[ JSON] RpcCall :> Post = "status" :> Get '[ JSON] Value :<|> ReqBody '[ JSON] RpcCall :> Post
'[ JSON] '[ JSON]
(RpcResponse Value) (RpcResponse Value)
zenithServer :: Server ZenithRPC zenithServer :: Config -> Server ZenithRPC
zenithServer = getinfo :<|> handleRPC zenithServer config = getinfo :<|> handleRPC
where where
getinfo :: Handler Value getinfo :: Handler Value
getinfo = getinfo =
@ -28,9 +42,15 @@ zenithServer = getinfo :<|> handleRPC
handleRPC :: RpcCall -> Handler (RpcResponse Value) handleRPC :: RpcCall -> Handler (RpcResponse Value)
handleRPC req = handleRPC req =
case method req of case method req of
UnknownMethod ->
return $
MakeRpcResponse
(Just $ RpcError (-32601) "Method not found")
(callId req)
Nothing
GetInfo -> GetInfo ->
case parameters req of case parameters req of
GetInfoParams -> BlankParams ->
return $ return $
MakeRpcResponse MakeRpcResponse
Nothing Nothing
@ -53,3 +73,11 @@ zenithServer = getinfo :<|> handleRPC
(Just $ RpcError (-32602) "Invalid params") (Just $ RpcError (-32602) "Invalid params")
(callId req) (callId req)
Nothing Nothing
authenticate :: Config -> BasicAuthCheck Bool
authenticate config = BasicAuthCheck check
where
check (BasicAuthData username password) =
if username == c_zenithUser config && password == c_zenithPwd config
then return $ Authorized True
else return Unauthorized