-- Copyright 2020 Fernando Rincon Martin
-- 
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
-- 
--     http://www.apache.org/licenses/LICENSE-2.0
-- 
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
-------------------------------------------------------------------------------
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.Wai.Routing.Purescheme.Core.Basic
  ( GenericApplication
  , Rejection(..)
  , FromUri(..)
  , HasResponseHeaders(..)
  , alternatives
  , handleException
  , withDefaultExceptionHandler
  , complete
  , completeIO
  , mapResponse
  , withRequest
  , withIO
  )
where

import Network.Wai.Routing.Purescheme.Core.Internal

import Control.Exception (Exception, catch)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import Data.Int (Int32, Int64)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import Network.HTTP.Types (ResponseHeaders, hContentType)
import Network.Wai (Response, ResponseReceived, Request, responseLBS)
import qualified Network.Wai as Wai

-- | Abstraction of Wai @'Application' on the type of response
type GenericApplication r = Request -> (r -> IO ResponseReceived) -> IO ResponseReceived

-- | Class of types that can be converted from the uri
class FromUri a where
  fromText :: T.Text -> a
  fromByteString :: ByteString -> a
  fromByteString = Text -> a
forall a. FromUri a => Text -> a
fromText (Text -> a) -> (ByteString -> Text) -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8

instance FromUri T.Text where
  fromText :: Text -> Text
fromText = Text -> Text
forall a. a -> a
id

instance FromUri Bool where
  fromText :: Text -> Bool
fromText Text
p = String -> Bool
forall a. Read a => String -> a
read (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
p

instance FromUri Int where
  fromText :: Text -> Int
fromText Text
p = String -> Int
forall a. Read a => String -> a
read (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
p

instance FromUri Int32 where
  fromText :: Text -> Int32
fromText Text
p = String -> Int32
forall a. Read a => String -> a
read (String -> Int32) -> String -> Int32
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
p

instance FromUri Int64 where
  fromText :: Text -> Int64
fromText Text
p = String -> Int64
forall a. Read a => String -> a
read (String -> Int64) -> String -> Int64
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
p

instance FromUri LT.Text where
  fromText :: Text -> Text
fromText = Text -> Text
LT.fromStrict

-- | Class which instaances contains response heaaders
class HasResponseHeaders a where
  mapResponseHeaders :: (ResponseHeaders -> ResponseHeaders) -> a -> a

instance HasResponseHeaders Response where
  mapResponseHeaders :: (ResponseHeaders -> ResponseHeaders) -> Response -> Response
mapResponseHeaders = (ResponseHeaders -> ResponseHeaders) -> Response -> Response
Wai.mapResponseHeaders

-- | Combines multiple generic applications in one
-- This function will try every application for each request, and return the first
-- response that does not fail
--
-- In case of rejections (Reection thrown), it will rethrown the first
-- exception with higher priority
alternatives :: [GenericApplication r] -> GenericApplication r
alternatives :: [GenericApplication r] -> GenericApplication r
alternatives = Rejection -> [GenericApplication r] -> GenericApplication r
forall r.
Rejection -> [GenericApplication r] -> GenericApplication r
alternatives' Rejection
notFoundDefaultRejection
  where
    alternatives' :: Rejection -> [GenericApplication r] -> GenericApplication r
    alternatives' :: Rejection -> [GenericApplication r] -> GenericApplication r
alternatives' Rejection
rejection [] Request
_ r -> IO ResponseReceived
_ = Rejection -> IO ResponseReceived
reject' Rejection
rejection
    alternatives' Rejection
rejection (GenericApplication r
x:[GenericApplication r]
xs) Request
req r -> IO ResponseReceived
respond =
      GenericApplication r
x Request
req r -> IO ResponseReceived
respond IO ResponseReceived
-> (Rejection -> IO ResponseReceived) -> IO ResponseReceived
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \Rejection
e -> Rejection -> [GenericApplication r] -> GenericApplication r
forall r.
Rejection -> [GenericApplication r] -> GenericApplication r
alternatives' (Rejection -> Rejection -> Rejection
chooseRejection Rejection
rejection Rejection
e) [GenericApplication r]
xs Request
req r -> IO ResponseReceived
respond

    chooseRejection :: Rejection -> Rejection -> Rejection
chooseRejection Rejection
r1 Rejection
r2 = 
      if Rejection -> Int
priority Rejection
r1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Rejection -> Int
priority Rejection
r2
        then Rejection
r2
        else Rejection
r1

-- Exception Handler functions

-- | Capture exceptions and convert to generic applications
handleException :: Exception e => (e -> GenericApplication a) -> GenericApplication a -> GenericApplication a
handleException :: (e -> GenericApplication a)
-> GenericApplication a -> GenericApplication a
handleException e -> GenericApplication a
exceptionFunc GenericApplication a
innerApp Request
req a -> IO ResponseReceived
resp = 
  IO ResponseReceived
-> (e -> IO ResponseReceived) -> IO ResponseReceived
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (GenericApplication a
innerApp Request
req a -> IO ResponseReceived
resp) (\e
e -> e -> GenericApplication a
exceptionFunc e
e Request
req a -> IO ResponseReceived
resp)

-- | By default capture all @'Rejection' and convert them in specific responses
-- the content type returned is 'text/plain" and the body will contain the error message
withDefaultExceptionHandler :: GenericApplication Response -> GenericApplication Response
withDefaultExceptionHandler :: GenericApplication Response -> GenericApplication Response
withDefaultExceptionHandler = (Rejection -> GenericApplication Response)
-> GenericApplication Response -> GenericApplication Response
forall e a.
Exception e =>
(e -> GenericApplication a)
-> GenericApplication a -> GenericApplication a
handleException Rejection -> GenericApplication Response
handleRejection
  where
    handleRejection :: Rejection -> GenericApplication Response
    handleRejection :: Rejection -> GenericApplication Response
handleRejection Rejection{Status
status :: Rejection -> Status
status :: Status
status, Text
message :: Rejection -> Text
message :: Text
message} Request
_ Response -> IO ResponseReceived
respond = 
      Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status [(HeaderName
hContentType, ByteString
"text/plain")] (ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
message)

-- | Ends the request responding with the argument
complete :: a -> GenericApplication a
complete :: a -> GenericApplication a
complete a
response Request
_ a -> IO ResponseReceived
respond = a -> IO ResponseReceived
respond a
response

-- | Ends the request excuting the provided IO and responding the result of the IO
completeIO :: IO a -> GenericApplication a
completeIO :: IO a -> GenericApplication a
completeIO IO a
responseIO Request
_ a -> IO ResponseReceived
respond = do
  a
response <- IO a
responseIO
  a -> IO ResponseReceived
respond a
response

-- | Execute an IO Action and pass it to the provided function
withIO :: IO a -> (a -> GenericApplication b) -> GenericApplication b
withIO :: IO a -> (a -> GenericApplication b) -> GenericApplication b
withIO IO a
theIO a -> GenericApplication b
f Request
req b -> IO ResponseReceived
respond = do
  a
var <- IO a
theIO
  a -> GenericApplication b
f a
var Request
req b -> IO ResponseReceived
respond

-- | Maps a response type to another response type
mapResponse :: (a -> b) -> GenericApplication a -> GenericApplication b
mapResponse :: (a -> b) -> GenericApplication a -> GenericApplication b
mapResponse a -> b
mapf GenericApplication a
inner Request
req b -> IO ResponseReceived
respond = GenericApplication a
inner Request
req (b -> IO ResponseReceived
respond (b -> IO ResponseReceived) -> (a -> b) -> a -> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
mapf)

-- | Pass the request to the provided function
withRequest :: (Request -> GenericApplication a) -> GenericApplication a
withRequest :: (Request -> GenericApplication a) -> GenericApplication a
withRequest Request -> GenericApplication a
reqFun Request
req = Request -> GenericApplication a
reqFun Request
req Request
req