{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

-- | An internal module. Depend on this at your own risk -- breaking changes to
-- this module's interface will not be represented as a major version bump.
module Rowdy.Yesod.Internal where

import           Data.Char             (toUpper)
import           Data.Either           (isLeft, lefts, rights)
import           Data.Maybe            (isJust)
import           Data.String           (IsString (..))
import           Data.Typeable         (Proxy (..), Typeable, eqT, typeRep)
import           Yesod.Routes.TH.Types

import           Rowdy

-- | An endpoint in the Yesod model.
data Endpoint
    = MkResource Verb String
    -- ^ A resource identified by a 'Verb' and a 'String' name.
    | MkSubsite String String String
    -- ^ A subsite.
    deriving (Endpoint -> Endpoint -> Bool
(Endpoint -> Endpoint -> Bool)
-> (Endpoint -> Endpoint -> Bool) -> Eq Endpoint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Endpoint -> Endpoint -> Bool
$c/= :: Endpoint -> Endpoint -> Bool
== :: Endpoint -> Endpoint -> Bool
$c== :: Endpoint -> Endpoint -> Bool
Eq, Int -> Endpoint -> ShowS
[Endpoint] -> ShowS
Endpoint -> String
(Int -> Endpoint -> ShowS)
-> (Endpoint -> String) -> ([Endpoint] -> ShowS) -> Show Endpoint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Endpoint] -> ShowS
$cshowList :: [Endpoint] -> ShowS
show :: Endpoint -> String
$cshow :: Endpoint -> String
showsPrec :: Int -> Endpoint -> ShowS
$cshowsPrec :: Int -> Endpoint -> ShowS
Show)

-- | The type of things that can affect a path.
data PathPiece
    = Literal String
    -- ^ Static string literals.
    | Capture Type
    -- ^ Dynamic captures.
    | Attr String
    -- ^ Route attributes. Not technically part of the path, but applies to
    -- everything below it in the tree.
    deriving (PathPiece -> PathPiece -> Bool
(PathPiece -> PathPiece -> Bool)
-> (PathPiece -> PathPiece -> Bool) -> Eq PathPiece
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PathPiece -> PathPiece -> Bool
$c/= :: PathPiece -> PathPiece -> Bool
== :: PathPiece -> PathPiece -> Bool
$c== :: PathPiece -> PathPiece -> Bool
Eq, Int -> PathPiece -> ShowS
[PathPiece] -> ShowS
PathPiece -> String
(Int -> PathPiece -> ShowS)
-> (PathPiece -> String)
-> ([PathPiece] -> ShowS)
-> Show PathPiece
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PathPiece] -> ShowS
$cshowList :: [PathPiece] -> ShowS
show :: PathPiece -> String
$cshow :: PathPiece -> String
showsPrec :: Int -> PathPiece -> ShowS
$cshowsPrec :: Int -> PathPiece -> ShowS
Show)

instance IsString PathPiece where
    fromString :: String -> PathPiece
fromString = String -> PathPiece
Literal

-- | A value containing a 'Proxy' of some Haskell type.
data Type where
    Type :: Typeable t => Proxy t -> Type

instance Show Type where
    show :: Type -> String
show (Type Proxy t
prxy) = TypeRep -> String
forall a. Show a => a -> String
show (Proxy t -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy t
prxy)

instance Eq Type where
    Type (Proxy t
_ :: Proxy t0) == :: Type -> Type -> Bool
== Type (Proxy t
_ :: Proxy t1) =
        Maybe (t :~: t) -> Bool
forall a. Maybe a -> Bool
isJust ((Typeable t, Typeable t) => Maybe (t :~: t)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @t0 @t1)

-- | The HTTP verbs.
data Verb = Get | Put | Post | Delete
    deriving (Verb -> Verb -> Bool
(Verb -> Verb -> Bool) -> (Verb -> Verb -> Bool) -> Eq Verb
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verb -> Verb -> Bool
$c/= :: Verb -> Verb -> Bool
== :: Verb -> Verb -> Bool
$c== :: Verb -> Verb -> Bool
Eq, Int -> Verb -> ShowS
[Verb] -> ShowS
Verb -> String
(Int -> Verb -> ShowS)
-> (Verb -> String) -> ([Verb] -> ShowS) -> Show Verb
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Verb] -> ShowS
$cshowList :: [Verb] -> ShowS
show :: Verb -> String
$cshow :: Verb -> String
showsPrec :: Int -> Verb -> ShowS
$cshowsPrec :: Int -> Verb -> ShowS
Show)

-- | Render a verb as an uppercase string.
renderVerb :: Verb -> String
renderVerb :: Verb -> String
renderVerb = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper ShowS -> (Verb -> String) -> Verb -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verb -> String
forall a. Show a => a -> String
show

-- | Convert the Rowdy 'RouteTree' structure into one appropriate for the Yesod
-- routing functions.
routeTreeToResourceTree :: [RouteTree String PathPiece Endpoint] -> [ResourceTree String]
routeTreeToResourceTree :: [RouteTree String PathPiece Endpoint] -> [ResourceTree String]
routeTreeToResourceTree =
    (RouteTree String PathPiece Endpoint
 -> [ResourceTree String] -> [ResourceTree String])
-> [ResourceTree String]
-> [RouteTree String PathPiece Endpoint]
-> [ResourceTree String]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Either String (Piece String)]
-> RouteTree String PathPiece Endpoint
-> [ResourceTree String]
-> [ResourceTree String]
go []) []
  where
    go
        :: [Either String (Piece String)]
        -> RouteTree String PathPiece Endpoint
        -> [ResourceTree String]
        -> [ResourceTree String]
    go :: [Either String (Piece String)]
-> RouteTree String PathPiece Endpoint
-> [ResourceTree String]
-> [ResourceTree String]
go [Either String (Piece String)]
pcs (Nest String
str [RouteTree String PathPiece Endpoint]
xs) [ResourceTree String]
acc =
        String
-> Bool
-> [Piece String]
-> [ResourceTree String]
-> ResourceTree String
forall typ.
String
-> Bool -> [Piece typ] -> [ResourceTree typ] -> ResourceTree typ
ResourceParent String
str Bool
True [Piece String]
pieces ((RouteTree String PathPiece Endpoint
 -> [ResourceTree String] -> [ResourceTree String])
-> [ResourceTree String]
-> [RouteTree String PathPiece Endpoint]
-> [ResourceTree String]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Either String (Piece String)]
-> RouteTree String PathPiece Endpoint
-> [ResourceTree String]
-> [ResourceTree String]
go [Either String (Piece String)]
attrs) [] [RouteTree String PathPiece Endpoint]
xs) ResourceTree String
-> [ResourceTree String] -> [ResourceTree String]
forall a. a -> [a] -> [a]
: [ResourceTree String]
acc
      where
        pieces :: [Piece String]
pieces = [Either String (Piece String)] -> [Piece String]
forall a b. [Either a b] -> [b]
rights ([Either String (Piece String)] -> [Either String (Piece String)]
forall a. [a] -> [a]
reverse [Either String (Piece String)]
pcs)
        attrs :: [Either String (Piece String)]
attrs = (Either String (Piece String) -> Bool)
-> [Either String (Piece String)] -> [Either String (Piece String)]
forall a. (a -> Bool) -> [a] -> [a]
filter Either String (Piece String) -> Bool
forall a b. Either a b -> Bool
isLeft [Either String (Piece String)]
pcs
    go [Either String (Piece String)]
pcs (PathComponent PathPiece
pp RouteTree String PathPiece Endpoint
rest) [ResourceTree String]
acc =
         [Either String (Piece String)]
-> RouteTree String PathPiece Endpoint
-> [ResourceTree String]
-> [ResourceTree String]
go (PathPiece -> Either String (Piece String)
convPiece PathPiece
pp Either String (Piece String)
-> [Either String (Piece String)] -> [Either String (Piece String)]
forall a. a -> [a] -> [a]
: [Either String (Piece String)]
pcs) RouteTree String PathPiece Endpoint
rest [ResourceTree String]
acc
    go [Either String (Piece String)]
pcs (Leaf Endpoint
term) (ResourceLeaf Resource {Bool
String
[String]
[Piece String]
Dispatch String
resourceName :: forall typ. Resource typ -> String
resourcePieces :: forall typ. Resource typ -> [Piece typ]
resourceDispatch :: forall typ. Resource typ -> Dispatch typ
resourceAttrs :: forall typ. Resource typ -> [String]
resourceCheck :: forall typ. Resource typ -> Bool
resourceCheck :: Bool
resourceAttrs :: [String]
resourceDispatch :: Dispatch String
resourcePieces :: [Piece String]
resourceName :: String
..} : [ResourceTree String]
acc)
        | (Piece String -> Piece String -> Bool)
-> [Piece String] -> [Piece String] -> Bool
forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
listEq Piece String -> Piece String -> Bool
eqPieceStr ([Either String (Piece String)] -> [Piece String]
forall a b. [Either a b] -> [b]
rights ([Either String (Piece String)] -> [Either String (Piece String)]
forall a. [a] -> [a]
reverse [Either String (Piece String)]
pcs)) [Piece String]
resourcePieces
        , Methods Maybe String
multi [String]
methods <- Dispatch String
resourceDispatch
        , MkResource Verb
_ String
endpointName <- Endpoint
term
        , String
resourceName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
endpointName
        =
        (ResourceTree String
 -> [ResourceTree String] -> [ResourceTree String])
-> [ResourceTree String]
-> ResourceTree String
-> [ResourceTree String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:) [ResourceTree String]
acc (ResourceTree String -> [ResourceTree String])
-> (Resource String -> ResourceTree String)
-> Resource String
-> [ResourceTree String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resource String -> ResourceTree String
forall typ. Resource typ -> ResourceTree typ
ResourceLeaf (Resource String -> [ResourceTree String])
-> Resource String -> [ResourceTree String]
forall a b. (a -> b) -> a -> b
$
            case Endpoint
term of
                MkResource Verb
v String
str ->
                    Resource :: forall typ.
String
-> [Piece typ] -> Dispatch typ -> [String] -> Bool -> Resource typ
Resource
                        { resourceName :: String
resourceName = String
str
                        , resourcePieces :: [Piece String]
resourcePieces = [Either String (Piece String)] -> [Piece String]
forall a b. [Either a b] -> [b]
rights ([Either String (Piece String)] -> [Either String (Piece String)]
forall a. [a] -> [a]
reverse [Either String (Piece String)]
pcs)
                        , resourceDispatch :: Dispatch String
resourceDispatch =
                            Methods :: forall typ. Maybe typ -> [String] -> Dispatch typ
Methods
                                { methodsMulti :: Maybe String
methodsMulti = Maybe String
multi
                                , methodsMethods :: [String]
methodsMethods = Verb -> String
renderVerb Verb
v String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
methods
                                }
                        , resourceAttrs :: [String]
resourceAttrs =
                            [Either String (Piece String)] -> [String]
forall a b. [Either a b] -> [a]
lefts [Either String (Piece String)]
pcs
                        , resourceCheck :: Bool
resourceCheck =
                            Bool
True
                        }
                MkSubsite String
str String
typ String
func ->
                    Resource :: forall typ.
String
-> [Piece typ] -> Dispatch typ -> [String] -> Bool -> Resource typ
Resource
                        { resourceName :: String
resourceName = String
str
                        , resourcePieces :: [Piece String]
resourcePieces = [Piece String] -> [Piece String]
forall a. [a] -> [a]
reverse ([Either String (Piece String)] -> [Piece String]
forall a b. [Either a b] -> [b]
rights [Either String (Piece String)]
pcs)
                        , resourceDispatch :: Dispatch String
resourceDispatch =
                            Subsite :: forall typ. typ -> String -> Dispatch typ
Subsite
                                { subsiteType :: String
subsiteType = String
typ
                                , subsiteFunc :: String
subsiteFunc = String
func
                                }
                        , resourceAttrs :: [String]
resourceAttrs =
                            [Either String (Piece String)] -> [String]
forall a b. [Either a b] -> [a]
lefts [Either String (Piece String)]
pcs
                        , resourceCheck :: Bool
resourceCheck =
                            Bool
True
                        }
    go [Either String (Piece String)]
pcs (Leaf Endpoint
term) [ResourceTree String]
acc =
        (ResourceTree String
 -> [ResourceTree String] -> [ResourceTree String])
-> [ResourceTree String]
-> ResourceTree String
-> [ResourceTree String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:) [ResourceTree String]
acc (ResourceTree String -> [ResourceTree String])
-> (Resource String -> ResourceTree String)
-> Resource String
-> [ResourceTree String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resource String -> ResourceTree String
forall typ. Resource typ -> ResourceTree typ
ResourceLeaf (Resource String -> [ResourceTree String])
-> Resource String -> [ResourceTree String]
forall a b. (a -> b) -> a -> b
$
            case Endpoint
term of
                MkResource Verb
v String
str ->
                    Resource :: forall typ.
String
-> [Piece typ] -> Dispatch typ -> [String] -> Bool -> Resource typ
Resource
                        { resourceName :: String
resourceName = String
str
                        , resourcePieces :: [Piece String]
resourcePieces = [Piece String] -> [Piece String]
forall a. [a] -> [a]
reverse ([Either String (Piece String)] -> [Piece String]
forall a b. [Either a b] -> [b]
rights [Either String (Piece String)]
pcs)
                        , resourceDispatch :: Dispatch String
resourceDispatch =
                            Methods :: forall typ. Maybe typ -> [String] -> Dispatch typ
Methods
                                { methodsMulti :: Maybe String
methodsMulti = Maybe String
forall a. Maybe a
Nothing
                                , methodsMethods :: [String]
methodsMethods = [Verb -> String
renderVerb Verb
v]
                                }
                        , resourceAttrs :: [String]
resourceAttrs =
                            [Either String (Piece String)] -> [String]
forall a b. [Either a b] -> [a]
lefts [Either String (Piece String)]
pcs
                        , resourceCheck :: Bool
resourceCheck =
                            Bool
True
                        }
                MkSubsite String
str String
typ String
func ->
                    Resource :: forall typ.
String
-> [Piece typ] -> Dispatch typ -> [String] -> Bool -> Resource typ
Resource
                        { resourceName :: String
resourceName = String
str
                        , resourcePieces :: [Piece String]
resourcePieces = [Piece String] -> [Piece String]
forall a. [a] -> [a]
reverse ([Either String (Piece String)] -> [Piece String]
forall a b. [Either a b] -> [b]
rights [Either String (Piece String)]
pcs)
                        , resourceDispatch :: Dispatch String
resourceDispatch =
                            Subsite :: forall typ. typ -> String -> Dispatch typ
Subsite
                                { subsiteType :: String
subsiteType = String
typ
                                , subsiteFunc :: String
subsiteFunc = String
func
                                }
                        , resourceAttrs :: [String]
resourceAttrs =
                            [Either String (Piece String)] -> [String]
forall a b. [Either a b] -> [a]
lefts [Either String (Piece String)]
pcs
                        , resourceCheck :: Bool
resourceCheck =
                            Bool
True
                        }

    convPiece :: PathPiece -> Either String (Piece String)
    convPiece :: PathPiece -> Either String (Piece String)
convPiece = \case
        Literal String
str -> Piece String -> Either String (Piece String)
forall a b. b -> Either a b
Right (String -> Piece String
forall typ. String -> Piece typ
Static String
str)
        Capture (Type Proxy t
prxy) -> Piece String -> Either String (Piece String)
forall a b. b -> Either a b
Right (String -> Piece String
forall typ. typ -> Piece typ
Dynamic (TypeRep -> String
forall a. Show a => a -> String
show (Proxy t -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy t
prxy)))
        Attr String
attr -> String -> Either String (Piece String)
forall a b. a -> Either a b
Left String
attr

    listEq :: (a -> a -> Bool) -> [a] -> [a] -> Bool
    listEq :: (a -> a -> Bool) -> [a] -> [a] -> Bool
listEq a -> a -> Bool
f (a
x:[a]
xs) (a
y:[a]
ys) = a -> a -> Bool
f a
x a
y Bool -> Bool -> Bool
&& (a -> a -> Bool) -> [a] -> [a] -> Bool
forall a. (a -> a -> Bool) -> [a] -> [a] -> Bool
listEq a -> a -> Bool
f [a]
xs [a]
ys
    listEq a -> a -> Bool
_ [] []         = Bool
True
    listEq a -> a -> Bool
_ [a]
_ [a]
_           = Bool
False

    eqPieceStr :: Piece String -> Piece String -> Bool
    eqPieceStr :: Piece String -> Piece String -> Bool
eqPieceStr (Static String
s2) (Static String
s1)   = String
s1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s2
    eqPieceStr (Dynamic String
d0) (Dynamic String
d1) = String
d0 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
d1
    eqPieceStr Piece String
_ Piece String
_                       = Bool
False