{-# LANGUAGE OverloadedStrings, DeriveGeneric #-}

module Keter.Config.Middleware where

import Data.Aeson
import GHC.Generics
import Prelude
import Network.Wai

import Control.Monad
import Control.Arrow ((***))

-- various Middlewares
import Network.Wai.Middleware.AcceptOverride  (acceptOverride)
import Network.Wai.Middleware.Autohead        (autohead)
import Network.Wai.Middleware.Jsonp           (jsonp)
import Network.Wai.Middleware.Local           (local)
import Network.Wai.Middleware.AddHeaders      (addHeaders)
import Network.Wai.Middleware.MethodOverride  (methodOverride)
import Network.Wai.Middleware.MethodOverridePost (methodOverridePost)
import Network.Wai.Middleware.HttpAuth        (basicAuth)

import Data.ByteString.Lazy         as L (ByteString)
import Data.ByteString  as S (ByteString)

import Data.Text.Lazy.Encoding as TL (encodeUtf8, decodeUtf8)
import Data.Text.Encoding as T (encodeUtf8, decodeUtf8)
import Data.String (fromString)
import qualified Keter.Aeson.KeyHelper as AK (toKey, toText, toList, empty)

data MiddlewareConfig = AcceptOverride
                      | Autohead
                      | Jsonp
                      | MethodOverride
                      | MethodOverridePost
                      | AddHeaders ![(S.ByteString, S.ByteString)]
                      | BasicAuth !String ![(S.ByteString, S.ByteString)]
                         -- ^ Realm [(username,password)]
                      | Local !Int !L.ByteString
                         -- ^ Status Message
          deriving (Int -> MiddlewareConfig -> ShowS
[MiddlewareConfig] -> ShowS
MiddlewareConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MiddlewareConfig] -> ShowS
$cshowList :: [MiddlewareConfig] -> ShowS
show :: MiddlewareConfig -> String
$cshow :: MiddlewareConfig -> String
showsPrec :: Int -> MiddlewareConfig -> ShowS
$cshowsPrec :: Int -> MiddlewareConfig -> ShowS
Show,forall x. Rep MiddlewareConfig x -> MiddlewareConfig
forall x. MiddlewareConfig -> Rep MiddlewareConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MiddlewareConfig x -> MiddlewareConfig
$cfrom :: forall x. MiddlewareConfig -> Rep MiddlewareConfig x
Generic)

instance FromJSON MiddlewareConfig where
  parseJSON :: Value -> Parser MiddlewareConfig
parseJSON (String Text
"accept-override"     ) = forall (f :: * -> *) a. Applicative f => a -> f a
pure MiddlewareConfig
AcceptOverride
  parseJSON (String Text
"autohead"            ) = forall (f :: * -> *) a. Applicative f => a -> f a
pure MiddlewareConfig
Autohead
  parseJSON (String Text
"jsonp"               ) = forall (f :: * -> *) a. Applicative f => a -> f a
pure MiddlewareConfig
Jsonp
  parseJSON (String Text
"method-override"     ) = forall (f :: * -> *) a. Applicative f => a -> f a
pure MiddlewareConfig
MethodOverride
  parseJSON (String Text
"method-override-post") = forall (f :: * -> *) a. Applicative f => a -> f a
pure MiddlewareConfig
MethodOverridePost
  parseJSON (Object Object
o) =
     case forall v. KeyMap v -> [(Key, v)]
AK.toList Object
o of
      [(Key
"basic-auth", Object ( Object
o'))] -> String -> [(ByteString, ByteString)] -> MiddlewareConfig
BasicAuth  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o' forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"realm" forall a. Parser (Maybe a) -> a -> Parser a
.!= String
"keter"
                                                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a b. (a -> b) -> [a] -> [b]
map ((Text -> ByteString
T.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
AK.toText) forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> ByteString
T.encodeUtf8) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. KeyMap v -> [(Key, v)]
AK.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o' forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"creds"   forall a. Parser (Maybe a) -> a -> Parser a
.!= forall v. KeyMap v
AK.empty)
      [(Key
"headers"   , Object Object
_ )]    -> [(ByteString, ByteString)] -> MiddlewareConfig
AddHeaders forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((Text -> ByteString
T.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
AK.toText) forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> ByteString
T.encodeUtf8) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. KeyMap v -> [(Key, v)]
AK.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o  forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"headers" forall a. Parser (Maybe a) -> a -> Parser a
.!= forall v. KeyMap v
AK.empty
      [(Key
"local"     , Object Object
o')] -> Int -> ByteString -> MiddlewareConfig
Local  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o' forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"status" forall a. Parser (Maybe a) -> a -> Parser a
.!=  Int
401
                                            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> ByteString
TL.encodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o' forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"message" forall a. Parser (Maybe a) -> a -> Parser a
.!= Text
"Unauthorized Accessing from Localhost ONLY" )
      [(Key, Value)]
_                      -> forall (m :: * -> *) a. MonadPlus m => m a
mzero -- fail "Rule: unexpected format"
  parseJSON Value
_ = forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance ToJSON MiddlewareConfig where
  toJSON :: MiddlewareConfig -> Value
toJSON MiddlewareConfig
AcceptOverride     = Value
"accept-override"
  toJSON MiddlewareConfig
Autohead           = Value
"autohead"
  toJSON MiddlewareConfig
Jsonp              = Value
"jsonp"
  toJSON MiddlewareConfig
MethodOverride     = Value
"method-override"
  toJSON MiddlewareConfig
MethodOverridePost = Value
"method-override-post"
  toJSON (BasicAuth String
realm [(ByteString, ByteString)]
cred) = [(Key, Value)] -> Value
object [ Key
"basic-auth" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Key, Value)] -> Value
object [ Key
"realm" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
realm
                                                                  , Key
"creds" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Key, Value)] -> Value
object ( forall a b. (a -> b) -> [a] -> [b]
map ( (Text -> Key
AK.toKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8) forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Text -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8)) [(ByteString, ByteString)]
cred )
                                                                  ]
                                         ]
  toJSON (AddHeaders [(ByteString, ByteString)]
headers)   = [(Key, Value)] -> Value
object [ Key
"headers"    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Key, Value)] -> Value
object ( forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Key
AK.toKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8) forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8) [(ByteString, ByteString)]
headers)  ]
  toJSON (Local Int
sc ByteString
msg)         = [(Key, Value)] -> Value
object [ Key
"local"      forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Key, Value)] -> Value
object [ Key
"status" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
sc
                                                                  , Key
"message" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=  ByteString -> Text
TL.decodeUtf8 ByteString
msg 
                                                                  ]
                                         ]


{-- Still missing
-- CleanPath
-- Gzip
-- RequestLogger
-- Rewrite
-- Vhost
--}

processMiddleware :: [MiddlewareConfig] -> Middleware
processMiddleware :: [MiddlewareConfig] -> Middleware
processMiddleware = [Middleware] -> Middleware
composeMiddleware forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map MiddlewareConfig -> Middleware
toMiddleware

toMiddleware :: MiddlewareConfig -> Middleware
toMiddleware :: MiddlewareConfig -> Middleware
toMiddleware MiddlewareConfig
AcceptOverride     = Middleware
acceptOverride
toMiddleware MiddlewareConfig
Autohead           = Middleware
autohead
toMiddleware MiddlewareConfig
Jsonp              = Middleware
jsonp
toMiddleware (Local Int
s ByteString
c )       = Response -> Middleware
local ( Status -> ResponseHeaders -> ByteString -> Response
responseLBS (forall a. Enum a => Int -> a
toEnum Int
s) [] ByteString
c )
toMiddleware MiddlewareConfig
MethodOverride     = Middleware
methodOverride
toMiddleware MiddlewareConfig
MethodOverridePost = Middleware
methodOverridePost
toMiddleware (BasicAuth String
realm [(ByteString, ByteString)]
cred) = CheckCreds -> AuthSettings -> Middleware
basicAuth (\ByteString
u ByteString
p -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Eq a => a -> a -> Bool
==ByteString
p) forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
u [(ByteString, ByteString)]
cred ) (forall a. IsString a => String -> a
fromString String
realm)
toMiddleware (AddHeaders [(ByteString, ByteString)]
headers)   = [(ByteString, ByteString)] -> Middleware
addHeaders [(ByteString, ByteString)]
headers

-- composeMiddleware :
composeMiddleware :: [Middleware] -> Middleware
composeMiddleware :: [Middleware] -> Middleware
composeMiddleware = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)) forall a. a -> a
id