module Network.Miku.Engine where
import Control.Lens hiding (use)
import Control.Monad.Reader hiding (join)
import Control.Monad.State hiding (join)
import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.List
import Data.Maybe
import qualified Network.HTTP.Types as H
import Network.Miku.Config
import Network.Miku.Type
import Network.Miku.Utils
import Network.Wai
import Prelude hiding (())
import System.FilePath ((</>))
emptyResponse :: Response
emptyResponse = responseLBS H.status200
[("Content-Type", "text/plain")]
"empty app"
emptyApp :: Application
emptyApp _ respond = respond emptyResponse
miku :: MikuMonad -> Application
miku = flip miku_middleware emptyApp
use :: [Middleware] -> Middleware
use = foldl (.) id
miku_middleware :: MikuMonad -> Middleware
miku_middleware miku_monad =
let miku_state = execState miku_monad mempty
mime_filter = id
miku_middleware_stack = use miku_state ^. middlewares
miku_router_middleware = use miku_state ^. router
pre_installed_middleware_stack = use pre_installed_middlewares
in
use [pre_installed_middleware_stack, mime_filter, miku_middleware_stack, miku_router_middleware]
miku_router :: H.Method -> ByteString -> AppMonad -> Middleware
miku_router route_method route_string app_monad app = \env ->
if requestMethod env == route_method
then
case env & rawPathInfo & parse_params route_string of
Nothing -> app env
Just (_, params) ->
let mikuHeaders = params & map (first CI.mk)
miku_app = run_app_monad local (putNamespace miku_captures mikuHeaders) app_monad
in
miku_app env
else
app env
where
run_app_monad :: AppMonad -> Application
run_app_monad app_monad env respond = do
r <- runReaderT app_monad env & flip execStateT emptyResponse
respond r
parse_params :: ByteString -> ByteString -> Maybe (ByteString, [(ByteString, ByteString)])
parse_params "*" x = Just (x, [])
parse_params "" "" = Just ("", [])
parse_params "" _ = Nothing
parse_params "/" "" = Nothing
parse_params "/" "/" = Just ("/", [])
parse_params t s =
let template_tokens = B.split '/' t
url_tokens = B.split '/' s
_template_last_token_matches_everything = (template_tokens & length) > 0 && (["*"] `isSuffixOf` template_tokens)
_template_tokens_length_equals_url_token_length = (template_tokens & length) == (url_tokens & length)
in
if not _template_last_token_matches_everything || _template_tokens_length_equals_url_token_length
then Nothing
else
let rs = zipWith capture template_tokens url_tokens
in
if all isJust rs
then
let token_length = length template_tokens
location = B.pack "/" </> (B.unpack B.intercalate "/" take token_length url_tokens)
in
Just (location, rs & catMaybes & catMaybes)
else Nothing
where
capture x y
| ":" `isPrefixOf` B.unpack x = Just Just (B.tail x, y)
| x == "*" = Just Nothing
| x == y = Just Nothing
| otherwise = Nothing