{-# LANGUAGE OverloadedStrings, DeriveGeneric #-}

module Keter.Types.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 Data.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
(Int -> MiddlewareConfig -> ShowS)
-> (MiddlewareConfig -> String)
-> ([MiddlewareConfig] -> ShowS)
-> Show MiddlewareConfig
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. MiddlewareConfig -> Rep MiddlewareConfig x)
-> (forall x. Rep MiddlewareConfig x -> MiddlewareConfig)
-> Generic MiddlewareConfig
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"     ) = MiddlewareConfig -> Parser MiddlewareConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure MiddlewareConfig
AcceptOverride
  parseJSON (String Text
"autohead"            ) = MiddlewareConfig -> Parser MiddlewareConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure MiddlewareConfig
Autohead
  parseJSON (String Text
"jsonp"               ) = MiddlewareConfig -> Parser MiddlewareConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure MiddlewareConfig
Jsonp
  parseJSON (String Text
"method-override"     ) = MiddlewareConfig -> Parser MiddlewareConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure MiddlewareConfig
MethodOverride
  parseJSON (String Text
"method-override-post") = MiddlewareConfig -> Parser MiddlewareConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure MiddlewareConfig
MethodOverridePost
  parseJSON (Object Object
o) =
     case Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
AK.toList Object
o of
      [(Key
"basic-auth", Object ( Object
o'))] -> String -> [(ByteString, ByteString)] -> MiddlewareConfig
BasicAuth  (String -> [(ByteString, ByteString)] -> MiddlewareConfig)
-> Parser String
-> Parser ([(ByteString, ByteString)] -> MiddlewareConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o' Object -> Key -> Parser (Maybe String)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"realm" Parser (Maybe String) -> String -> Parser String
forall a. Parser (Maybe a) -> a -> Parser a
.!= String
"keter"
                                                Parser ([(ByteString, ByteString)] -> MiddlewareConfig)
-> Parser [(ByteString, ByteString)] -> Parser MiddlewareConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (((Key, Text) -> (ByteString, ByteString))
-> [(Key, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (Key -> Text) -> Key -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
AK.toText) (Key -> ByteString)
-> (Text -> ByteString) -> (Key, Text) -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> ByteString
T.encodeUtf8) ([(Key, Text)] -> [(ByteString, ByteString)])
-> (KeyMap Text -> [(Key, Text)])
-> KeyMap Text
-> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyMap Text -> [(Key, Text)]
forall v. KeyMap v -> [(Key, v)]
AK.toList (KeyMap Text -> [(ByteString, ByteString)])
-> Parser (KeyMap Text) -> Parser [(ByteString, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o' Object -> Key -> Parser (Maybe (KeyMap Text))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"creds"   Parser (Maybe (KeyMap Text)) -> KeyMap Text -> Parser (KeyMap Text)
forall a. Parser (Maybe a) -> a -> Parser a
.!= KeyMap Text
forall v. KeyMap v
AK.empty)
      [(Key
"headers"   , Object Object
_ )]    -> [(ByteString, ByteString)] -> MiddlewareConfig
AddHeaders ([(ByteString, ByteString)] -> MiddlewareConfig)
-> (KeyMap Text -> [(ByteString, ByteString)])
-> KeyMap Text
-> MiddlewareConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, Text) -> (ByteString, ByteString))
-> [(Key, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (Key -> Text) -> Key -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
AK.toText) (Key -> ByteString)
-> (Text -> ByteString) -> (Key, Text) -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> ByteString
T.encodeUtf8) ([(Key, Text)] -> [(ByteString, ByteString)])
-> (KeyMap Text -> [(Key, Text)])
-> KeyMap Text
-> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyMap Text -> [(Key, Text)]
forall v. KeyMap v -> [(Key, v)]
AK.toList (KeyMap Text -> MiddlewareConfig)
-> Parser (KeyMap Text) -> Parser MiddlewareConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o  Object -> Key -> Parser (Maybe (KeyMap Text))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"headers" Parser (Maybe (KeyMap Text)) -> KeyMap Text -> Parser (KeyMap Text)
forall a. Parser (Maybe a) -> a -> Parser a
.!= KeyMap Text
forall v. KeyMap v
AK.empty
      [(Key
"local"     , Object Object
o')] -> Int -> ByteString -> MiddlewareConfig
Local  (Int -> ByteString -> MiddlewareConfig)
-> Parser Int -> Parser (ByteString -> MiddlewareConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o' Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"status" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!=  Int
401
                                            Parser (ByteString -> MiddlewareConfig)
-> Parser ByteString -> Parser MiddlewareConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> Parser Text -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o' Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"message" Parser (Maybe Text) -> Text -> Parser Text
forall a. Parser (Maybe a) -> a -> Parser a
.!= Text
"Unauthorized Accessing from Localhost ONLY" )
      [(Key, Value)]
_                      -> Parser MiddlewareConfig
forall (m :: * -> *) a. MonadPlus m => m a
mzero -- fail "Rule: unexpected format"
  parseJSON Value
_ = Parser MiddlewareConfig
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" Key -> Value -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Key, Value)] -> Value
object [ Key
"realm" Key -> String -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
realm
                                                                  , Key
"creds" Key -> Value -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Key, Value)] -> Value
object ( ((ByteString, ByteString) -> (Key, Value))
-> [(ByteString, ByteString)] -> [(Key, Value)]
forall a b. (a -> b) -> [a] -> [b]
map ( (Text -> Key
AK.toKey (Text -> Key) -> (ByteString -> Text) -> ByteString -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8) (ByteString -> Key)
-> (ByteString -> Value)
-> (ByteString, ByteString)
-> (Key, Value)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Text -> Value
String (Text -> Value) -> (ByteString -> Text) -> ByteString -> Value
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"    Key -> Value -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Key, Value)] -> Value
object ( ((ByteString, ByteString) -> (Key, Value))
-> [(ByteString, ByteString)] -> [(Key, Value)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Key
AK.toKey (Text -> Key) -> (ByteString -> Text) -> ByteString -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8) (ByteString -> Key)
-> (ByteString -> Value)
-> (ByteString, ByteString)
-> (Key, Value)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> Value
String (Text -> Value) -> (ByteString -> Text) -> ByteString -> Value
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"      Key -> Value -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Key, Value)] -> Value
object [ Key
"status" Key -> Int -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
sc
                                                                  , Key
"message" Key -> Text -> (Key, Value)
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 ([Middleware] -> Middleware)
-> ([MiddlewareConfig] -> [Middleware])
-> [MiddlewareConfig]
-> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MiddlewareConfig -> Middleware)
-> [MiddlewareConfig] -> [Middleware]
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 (Int -> Status
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 -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
==ByteString
p) (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
u [(ByteString, ByteString)]
cred ) (String -> AuthSettings
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 = (Middleware -> Middleware -> Middleware)
-> Middleware -> [Middleware] -> Middleware
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Middleware -> Middleware -> Middleware)
-> Middleware -> Middleware -> Middleware
forall a b c. (a -> b -> c) -> b -> a -> c
flip Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)) Middleware
forall a. a -> a
id