{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
---------------------------------------------------------
--
-- Module        : Yesod.Resource
-- Copyright     : Michael Snoyman
-- License       : BSD3
--
-- Maintainer    : Michael Snoyman <michael@snoyman.com>
-- Stability     : Stable
-- Portability   : portable
--
-- Defines the ResourceName class.
--
---------------------------------------------------------
module Yesod.Resource
    ( resources
    , resourcesNoCheck
#if TEST
      -- * Testing
    , testSuite
#endif
    ) where

import Data.List.Split (splitOn)
import Yesod.Definitions
import Data.List (nub)
import Data.Char (isDigit)

import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote

import Data.Typeable (Typeable)
import Control.Exception (Exception)
import Data.Attempt -- for failure stuff
import Data.Object.Text
import Control.Monad ((<=<))
import Data.Object.Yaml
import Yesod.Handler
import Data.Maybe (fromJust)
#if TEST
import Yesod.Rep hiding (testSuite)
#else
import Yesod.Rep
#endif

#if TEST
import Control.Monad (replicateM)
import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck (testProperty)
import Test.HUnit hiding (Test)
import Test.QuickCheck
import Control.Monad (when)
#endif

-- | Resource Pattern Piece
data RPP =
    Static String
    | Dynamic String
    | DynInt String
    | Slurp String -- ^ take up the rest of the pieces. must be last
    deriving (Eq, Show)

-- | Resource Pattern
newtype RP = RP { unRP :: [RPP] }
    deriving (Eq, Show)

isSlurp :: RPP -> Bool
isSlurp (Slurp _) = True
isSlurp _ = False

instance ConvertSuccess String RP where
    convertSuccess = RP . map helper . filter (not . null) .splitOn "/"
      where
        helper :: String -> RPP
        helper ('$':rest) = Dynamic rest
        helper ('*':rest) = Slurp rest
        helper ('#':rest) = DynInt rest
        helper x = Static x
instance ConvertSuccess RP String where
    convertSuccess = concatMap helper . unRP where
        helper (Static s) = '/' : s
        helper (Dynamic s) = '/' : '$' : s
        helper (Slurp s) = '/' : '*' : s
        helper (DynInt s) = '/' : '#' : s

type ResourcePattern = String

data CheckPatternReturn =
    StaticMatch
  | DynamicMatch (String, String)
  | DynIntMatch (String, Int)
  | NoMatch

checkPatternBool :: RP -> Resource -> Bool
checkPatternBool rp r = case checkPattern rp r of
                            Nothing -> False
                            _ -> True

checkPatternUP :: RP -> Resource -> [UrlParam]
checkPatternUP rp r = map snd $ fromJust (checkPattern rp r)

checkPattern :: RP -> Resource -> Maybe [(String, UrlParam)]
checkPattern = checkPatternPieces . unRP

checkPatternPieces :: [RPP] -> Resource -> Maybe [(String, UrlParam)]
checkPatternPieces rp r
    | not (null rp) && isSlurp (last rp) = do
        let rp' = init rp
            (r1, r2) = splitAt (length rp') r
        smap <- checkPatternPieces rp' r1
        let Slurp slurpKey = last rp
        return $ (slurpKey, SlurpParam r2) : smap
    | length rp /= length r = Nothing
    | otherwise = combine [] $ zipWith checkPattern' rp r

checkPattern' :: RPP -> String -> CheckPatternReturn
checkPattern' (Static x) y = if x == y then StaticMatch else NoMatch
checkPattern' (Dynamic x) y = DynamicMatch (x, y)
checkPattern' (Slurp x) _ = error $ "Slurp pattern " ++ x ++ " must be last"
checkPattern' (DynInt x) y
    | all isDigit y = DynIntMatch (x, read y)
    | otherwise = NoMatch

combine :: [(String, UrlParam)]
        -> [CheckPatternReturn]
        -> Maybe [(String, UrlParam)]
combine s [] = Just $ reverse s
combine _ (NoMatch:_) = Nothing
combine s (StaticMatch:rest) = combine s rest
combine s (DynamicMatch (x, y):rest) = combine ((x, StringParam y):s) rest
combine s (DynIntMatch (x, y):rest) = combine ((x, IntParam y):s) rest

overlaps :: [RPP] -> [RPP] -> Bool
overlaps [] [] = True
overlaps [] _ = False
overlaps _ [] = False
overlaps (Slurp _:_) _ = True
overlaps _ (Slurp _:_) = True
overlaps (Dynamic _:x) (_:y) = overlaps x y
overlaps (_:x) (Dynamic _:y) = overlaps x y
overlaps (DynInt _:x) (DynInt _:y) = overlaps x y
overlaps (DynInt _:x) (Static s:y)
    | all isDigit s = overlaps x y
    | otherwise = False
overlaps (Static s:x) (DynInt _:y)
    | all isDigit s = overlaps x y
    | otherwise = False
overlaps (Static a:x) (Static b:y) = a == b && overlaps x y

data OverlappingPatterns =
    OverlappingPatterns [(ResourcePattern, ResourcePattern)]
    deriving (Show, Typeable)
instance Exception OverlappingPatterns

checkPatterns :: MonadFailure OverlappingPatterns f
              => [ResourcePattern]
              -> f ()
checkPatterns patterns =
    case validatePatterns patterns of
        [] -> return ()
        x -> failure $ OverlappingPatterns x

validatePatterns :: [ResourcePattern]
                 -> [(ResourcePattern, ResourcePattern)]
validatePatterns [] = []
validatePatterns (x:xs) =
  concatMap (validatePatterns' x) xs ++ validatePatterns xs where
    validatePatterns' :: ResourcePattern
                      -> ResourcePattern
                      -> [(ResourcePattern, ResourcePattern)]
    validatePatterns' a b =
        let a' = unRP $ cs a
            b' = unRP $ cs b
         in [(a, b) | overlaps a' b']

data RPNode = RPNode RP VerbMap
    deriving (Show, Eq)
data VerbMap = AllVerbs String | Verbs [(Verb, String)]
    deriving (Show, Eq)
instance ConvertAttempt YamlDoc [RPNode] where
    convertAttempt = fromTextObject <=< ca
instance ConvertAttempt TextObject [RPNode] where
    convertAttempt = mapM helper <=< fromMapping where
        helper :: (Text, TextObject) -> Attempt RPNode
        helper (rp, rest) = do
            verbMap <- fromTextObject rest
            let rp' = cs (cs rp :: String)
            return $ RPNode rp' verbMap
instance ConvertAttempt TextObject VerbMap where
    convertAttempt (Scalar s) = return $ AllVerbs $ cs s
    convertAttempt (Mapping m) = Verbs `fmap` mapM helper m where
        helper :: (Text, TextObject) -> Attempt (Verb, String)
        helper (v, Scalar f) = do
            v' <- ca (cs v :: String)
            return (v', cs f)
        helper (_, x) = failure $ VerbMapNonScalar x
    convertAttempt o = failure $ VerbMapSequence o
data RPNodeException = VerbMapNonScalar TextObject
                     | VerbMapSequence TextObject
    deriving (Show, Typeable)
instance Exception RPNodeException

checkRPNodes :: (MonadFailure OverlappingPatterns m,
                 MonadFailure RepeatedVerb m
                )
             => [RPNode]
             -> m [RPNode]
checkRPNodes nodes = do
    checkPatterns $ map (\(RPNode r _) -> cs r) nodes -- FIXME ugly
    mapM_ (\(RPNode _ v) -> checkVerbMap v) nodes
    return nodes
        where
            checkVerbMap (AllVerbs _) = return ()
            checkVerbMap (Verbs vs) =
                let vs' = map fst vs
                    res = nub vs' == vs'
                 in if res then return () else failure $ RepeatedVerb vs

newtype RepeatedVerb = RepeatedVerb [(Verb, String)]
    deriving (Show, Typeable)
instance Exception RepeatedVerb

rpnodesTHCheck :: [RPNode] -> Q Exp
rpnodesTHCheck nodes = do
    nodes' <- runIO $ checkRPNodes nodes
    res <- rpnodesTH nodes'
    -- For debugging purposes runIO $ putStrLn $ pprint res
    return res

notFoundVerb :: Verb -> Handler yesod a
notFoundVerb _verb = notFound

rpnodesTH :: [RPNode] -> Q Exp
rpnodesTH ns = do
    b <- helper ns
    nfv <- [|notFoundVerb|]
    ow <- [|otherwise|]
    let b' = b ++ [(NormalG ow, nfv)]
    return $ LamE [VarP $ mkName "resource"]
           $ CaseE (TupE []) [Match WildP (GuardedB b') []]
      where
        helper :: [RPNode] -> Q [(Guard, Exp)]
        helper nodes = mapM helper2 nodes
        helper2 :: RPNode -> Q (Guard, Exp)
        helper2 (RPNode rp vm) = do
            rp' <- lift rp
            cpb <- [|checkPatternBool|]
            let r' = VarE $ mkName "resource"
            let g = cpb `AppE` rp' `AppE` r'
            vm' <- liftVerbMap vm $ countParams rp
            vm'' <- applyUrlParams rp r' vm'
            let vm''' = LamE [VarP $ mkName "verb"] vm''
            return (NormalG g, vm''')

data UrlParam = SlurpParam { slurpParam :: [String] }
              | StringParam { stringParam :: String }
              | IntParam { intParam :: Int }
    deriving Show -- FIXME remove

getUrlParam :: RP -> Resource -> Int -> UrlParam
getUrlParam rp r i = checkPatternUP rp r !! i

getUrlParamSlurp :: RP -> Resource -> Int -> [String]
getUrlParamSlurp rp r = slurpParam . getUrlParam rp r

getUrlParamString :: RP -> Resource -> Int -> String
getUrlParamString rp r = stringParam . getUrlParam rp r

getUrlParamInt :: RP -> Resource -> Int -> Int
getUrlParamInt rp r = intParam . getUrlParam rp r

applyUrlParams :: RP -> Exp -> Exp -> Q Exp
applyUrlParams rp@(RP rpps) r f = do
    getFs <- helper 0 rpps
    return $ foldl AppE f getFs
        where
            helper :: Int -> [RPP] -> Q [Exp]
            helper _ [] = return []
            helper i (Static _:rest) = helper i rest
            helper i (Dynamic _:rest) = do
                rp' <- lift rp
                str <- [|getUrlParamString|]
                i' <- lift i
                rest' <- helper (i + 1) rest
                return $ str `AppE` rp' `AppE` r `AppE` i' : rest'
            helper i (DynInt _:rest) = do
                rp' <- lift rp
                int <- [|getUrlParamInt|]
                i' <- lift i
                rest' <- helper (i + 1) rest
                return $ int `AppE` rp' `AppE` r `AppE` i' : rest'
            helper i (Slurp _:rest) = do
                rp' <- lift rp
                slurp <- [|getUrlParamSlurp|]
                i' <- lift i
                rest' <- helper (i + 1) rest
                return $ slurp `AppE` rp' `AppE` r `AppE` i' : rest'

countParams :: RP -> Int
countParams (RP rpps) = helper 0 rpps where
    helper i [] = i
    helper i (Static _:rest) = helper i rest
    helper i (_:rest) = helper (i + 1) rest

instance Lift RPNode where
    lift (RPNode rp vm) = do
        rp' <- lift rp
        vm' <- liftVerbMap vm $ countParams rp
        return $ TupE [rp', vm']
instance Lift RP where
    lift (RP rpps) = do
        rpps' <- lift rpps
        rp <- [|RP|]
        return $ rp `AppE` rpps'
instance Lift RPP where
    lift (Static s) = do
        st <- [|Static|]
        return $ st `AppE` (LitE $ StringL s)
    lift (Dynamic s) = do
        d <- [|Dynamic|]
        return $ d `AppE` (LitE $ StringL s)
    lift (DynInt s) = do
        d <- [|DynInt|]
        return $ d `AppE` (LitE $ StringL s)
    lift (Slurp s) = do
        sl <- [|Slurp|]
        return $ sl `AppE` (LitE $ StringL s)
liftVerbMap :: VerbMap -> Int -> Q Exp
liftVerbMap (AllVerbs s) _ = do
    cr <- [|(.) (fmap chooseRep)|]
    return $ cr `AppE` ((VarE $ mkName s) `AppE` (VarE $ mkName "verb"))
liftVerbMap (Verbs vs) params =
      return $ CaseE (VarE $ mkName "verb")
             $ map helper vs ++ [whenNotFound]
        where
            helper :: (Verb, String) -> Match
            helper (v, f) =
                Match (ConP (mkName $ show v) [])
                      (NormalB $ VarE $ mkName f)
                      []
            whenNotFound :: Match
            whenNotFound =
                Match WildP
                      (NormalB $ LamE (replicate params WildP) $ VarE $ mkName "notFound")
                      []

strToExp :: Bool -> String -> Q Exp
strToExp toCheck s = do
    rpnodes <- runIO $ convertAttemptWrap $ YamlDoc $ cs s
    (if toCheck then rpnodesTHCheck else rpnodesTH) rpnodes

resources :: QuasiQuoter
resources = QuasiQuoter (strToExp True) undefined

resourcesNoCheck :: QuasiQuoter
resourcesNoCheck = QuasiQuoter (strToExp False) undefined

#if TEST
---- Testing
testSuite :: Test
testSuite = testGroup "Yesod.Resource"
    [ testCase "non-overlap" caseOverlap1
    , testCase "overlap" caseOverlap2
    , testCase "overlap-slurp" caseOverlap3
    , testCase "validatePatterns" caseValidatePatterns
    , testProperty "show pattern" prop_showPattern
    , testCase "integers" caseIntegers
    , testCase "read patterns from YAML" caseFromYaml
    , testCase "checkRPNodes" caseCheckRPNodes
    ]

deriving instance Arbitrary RP

caseOverlap1 :: Assertion
caseOverlap1 = assert $ not $ overlaps
                    (unRP $ cs "/foo/$bar/")
                    (unRP $ cs "/foo/baz/$bin")
caseOverlap2 :: Assertion
caseOverlap2 = assert $ overlaps
                    (unRP $ cs "/foo/bar")
                    (unRP $ cs "/foo/$baz")
caseOverlap3 :: Assertion
caseOverlap3 = assert $ overlaps
                    (unRP $ cs "/foo/bar/baz/$bin")
                    (unRP $ cs "*slurp")

caseValidatePatterns :: Assertion
caseValidatePatterns =
    let p1 = cs "/foo/bar/baz"
        p2 = cs "/foo/$bar/baz"
        p3 = cs "/bin"
        p4 = cs "/bin/boo"
        p5 = cs "/bin/*slurp"
     in validatePatterns [p1, p2, p3, p4, p5] @?=
            [ (p1, p2)
            , (p4, p5)
            ]

prop_showPattern :: RP -> Bool
prop_showPattern p = cs (cs p :: String) == p

caseIntegers :: Assertion
caseIntegers = do
    let p1 = "/foo/#bar/"
        p2 = "/foo/#baz/"
        p3 = "/foo/$bin/"
        p4 = "/foo/4/"
        p5 = "/foo/bar/"
        p6 = "/foo/*slurp/"
        checkOverlap :: String -> String -> Bool -> IO ()
        checkOverlap a b c = do
            let res1 = overlaps (unRP $ cs a) (unRP $ cs b)
            let res2 = overlaps (unRP $ cs b) (unRP $ cs a)
            when (res1 /= c || res2 /= c) $ assertString $ a
               ++ (if c then " does not overlap with " else " overlaps with ")
               ++ b
    checkOverlap p1 p2 True
    checkOverlap p1 p3 True
    checkOverlap p1 p4 True
    checkOverlap p1 p5 False
    checkOverlap p1 p6 True

instance Arbitrary RPP where
    arbitrary = do
        constr <- elements [Static, Dynamic, Slurp, DynInt]
        size <- elements [1..10]
        s <- replicateM size $ elements ['a'..'z']
        return $ constr s
    coarbitrary = undefined

caseFromYaml :: Assertion
caseFromYaml = do
    contents <- readYamlDoc "test/resource-patterns.yaml"
    let expected =
         [ RPNode (cs "static/*filepath") $ AllVerbs "getStatic"
         , RPNode (cs "page") $ Verbs [(Get, "pageIndex"), (Put, "pageAdd")]
         , RPNode (cs "page/$page") $ Verbs [ (Get, "pageDetail")
                                            , (Delete, "pageDelete")
                                            , (Post, "pageUpdate")
                                            ]
         , RPNode (cs "user/#id") $ Verbs [(Get, "userInfo")]
         ]
    contents' <- fa $ ca contents
    expected @=? contents'

caseCheckRPNodes :: Assertion
caseCheckRPNodes = do
    good' <- readYamlDoc "test/resource-patterns.yaml"
    good <- fa $ ca good'
    Just good @=? checkRPNodes good
    let bad1 = [ RPNode (cs "foo/bar") $ AllVerbs "foo"
               , RPNode (cs "$foo/bar") $ AllVerbs "bar"
               ]
    Nothing @=? checkRPNodes bad1
    let bad2 = [RPNode (cs "") $ Verbs [(Get, "foo"), (Get, "bar")]]
    Nothing @=? checkRPNodes bad2
#endif