{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
{- |
Module      :  Network.Wai.Middleware.Routes
Copyright   :  (c) Anupam Jain 2011
License     :  GNU GPL Version 3 (see the file LICENSE)

Maintainer  :  ajnsit@gmail.com
Stability   :  experimental
Portability :  non-portable (uses ghc extensions)

This package provides typesafe URLs for Wai applications.
-}
module Network.Wai.Middleware.Routes
    ( parseRoutes
    , parseRoutesFile
    , parseRoutesNoCheck
    , parseRoutesFileNoCheck
    , mkRoute
    , dispatch
    , Resource (..)
    , Piece (..)
    , Route (..)
    ) where

import Web.PathPieces
import Network.Wai
import Language.Haskell.TH.Syntax
import Data.Maybe
import Data.Either
import Data.List
import Data.Char (toLower)
import qualified Data.Text
import Language.Haskell.TH.Quote
import Data.Data
import qualified System.IO as SIO
import Data.Text (Text)
import Network.HTTP.Types (StdMethod(..), statusOK, statusNotAllowed, parseMethod)

-- | Instances of this class are autogenerated by @mkRoute@ TH function
class Route route where
  showRoute :: route -> [Text]
  readRoute :: [Text] -> Either String route
  dispatchRoute :: route -> String -> Maybe Application

-- | The application dispatcher function.
-- This function takes an instance of @Route@ class as an argument.
-- It is normal to pass (undefined::YourRoute).
dispatch :: Route route => route -> Middleware
dispatch route def req = case readRoute (pathInfo req) of
  Left s -> def req
  Right route' -> case dispatchRoute (route' `asTypeOf` route) (show $ method req) of
    Nothing -> def req
    Just app -> app req
  where
    method :: Request -> StdMethod
    method req = case parseMethod $ requestMethod req of
      Right m -> m
      Left  _ -> GET

-- | Call this function to automatically generate your route datatype and @Route@ instance 
mkRoute :: String -> [Resource] -> Q [Dec]
mkRoute name res = do
    cons <- createRoutes res
    let routesName = mkName $ name ++ "Route"
    let dataDecl = DataD [] routesName [] cons [''Show, ''Read, ''Eq]
    render <- createRender res
    reader <- createParse res
    dispatch <- createDispatch res
    let routeInstance = InstanceD [] (ConT ''Route `AppT` ConT routesName) [ FunD (mkName "showRoute") render , FunD (mkName "readRoute") reader, FunD (mkName "dispatchRoute") dispatch ]
    return [dataDecl, routeInstance]

createRoutes :: [Resource] -> Q [Con]
createRoutes res = return $ map go res
  where
    go (Resource n pieces _) = NormalC (mkName n) $ mapMaybe go' pieces
    go' (SinglePiece x) = Just (NotStrict, ConT $ mkName x)
    go' (MultiPiece x) = Just (NotStrict, ConT $ mkName x)
    go' (StaticPiece _) = Nothing

createParse :: [Resource] -> Q [Clause]
createParse res = do
    final' <- final
    clauses <- mapM go res
    return $ if areResourcesComplete res
                then clauses
                else clauses ++ [final']
  where
    cons x y = ConP (mkName ":") [x, y]
    go (Resource n ps _) = do
        ri <- [|Right|]
        be <- [|ape|]
        (pat, parse) <- mkPat' be ps $ ri `AppE` ConE (mkName n)
        return $ Clause [foldr1 cons pat] (NormalB parse) []
    final = do
        no <- [|Left "Invalid URL"|]
        return $ Clause [WildP] (NormalB no) []
    mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp)
    mkPat' be [MultiPiece s] parse = do
        v <- newName $ "var" ++ s
        fmp <- [|fromPathMultiPiece|]
        let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v
        return ([VarP v], parse')
    mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last"
    mkPat' be (StaticPiece s:rest) parse = do
        (x, parse') <- mkPat' be rest parse
        let sp = LitP $ StringL s
        return (sp : x, parse')
    mkPat' be (SinglePiece s:rest) parse = do
        fsp <- [|fromPathPiece|]
        v <- newName $ "var" ++ s
        let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v
        (x, parse'') <- mkPat' be rest parse'
        return (VarP v : x, parse'')
    mkPat' _ [] parse = return ([ListP []], parse)

ape :: Either String (a -> b) -> Maybe a -> Either String b
ape (Left e) _ = Left e
ape (Right _) Nothing = Left "Invalid URL"
ape (Right f) (Just a) = Right $ f a

createRender :: [Resource] -> Q [Clause]
createRender = mapM go
  where
    go (Resource n ps _) = do
        let ps' = zip [1..] ps
        let pat = ConP (mkName n) $ mapMaybe go' ps'
        bod <- mkBod ps'
        return $ Clause [pat] (NormalB bod) []
    go' (_, StaticPiece _) = Nothing
    go' (i, _) = Just $ VarP $ mkName $ "var" ++ show (i :: Int)
    mkBod :: (Show t) => [(t, Piece)] -> Q Exp
    mkBod [] = lift ([] :: [String])
    mkBod ((_, StaticPiece x):xs) = do
        x' <- lift x
        pack <- [|Data.Text.pack|]
        xs' <- mkBod xs
        return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs'
    mkBod ((i, SinglePiece _):xs) = do
        let x' = VarE $ mkName $ "var" ++ show i
        tsp <- [|toPathPiece|]
        let x'' = tsp `AppE` x'
        xs' <- mkBod xs
        return $ ConE (mkName ":") `AppE` x'' `AppE` xs'
    mkBod ((i, MultiPiece _):_) = do
        let x' = VarE $ mkName $ "var" ++ show i
        tmp <- [|toPathMultiPiece|]
        return $ tmp `AppE` x'

areResourcesComplete :: [Resource] -> Bool
areResourcesComplete res =
    let (slurps, noSlurps) = partitionEithers $ mapMaybe go res
     in case slurps of
            [] -> False
            _ -> let minSlurp = minimum slurps
                  in helper minSlurp $ reverse $ sort noSlurps
  where
    go :: Resource -> Maybe (Either Int Int)
    go (Resource _ ps _) =
        case reverse ps of
            [] -> Just $ Right 0
            (MultiPiece _:rest) -> go' Left rest
            x -> go' Right x
    go' b x = if all isSingle x then Just (b $ length x) else Nothing
    helper 0 _ = True
    helper _ [] = False
    helper m (i:is)
        | i >= m = helper m is
        | i + 1 == m = helper i is
        | otherwise = False
    isSingle (SinglePiece _) = True
    isSingle _ = False

notStatic :: Piece -> Bool
notStatic StaticPiece{} = False
notStatic _ = True

createDispatch :: [Resource] -> Q [Clause]
createDispatch = mapM go
  where
    go :: Resource -> Q Clause
    go (Resource n ps methods) = do
        meth <- newName "method"
        xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
        let pat = [ ConP (mkName n) $ map VarP xs
                  , if null methods then WildP else VarP meth
                  ]
        bod <- go' n meth xs methods
        return $ Clause pat (NormalB bod) []
    go' n _ xs [] = do
        jus <- [|Just|]
        let bod = foldl AppE (VarE $ mkName $ "handle" ++ n) $ map VarE xs
        return $ jus `AppE` bod
    go' n meth xs methods = do
        noth <- [|Nothing|]
        j <- [|Just|]
        let noMatch = Match WildP (NormalB noth) []
        return $ CaseE (VarE meth) $ map (go'' n xs j) methods ++ [noMatch]
    go'' n xs j method =
        let pat = LitP $ StringL method
            func = map toLower method ++ n
            bod = foldl AppE (VarE $ mkName func) $ map VarE xs
         in Match pat (NormalB $ j `AppE` bod) []

-- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for
-- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the
-- checking
parseRoutes :: QuasiQuoter
parseRoutes = QuasiQuoter
    { quoteExp = x
    , quotePat = y
    }
  where
    x s = do
        let res = resourcesFromString s
        case findOverlaps res of
            [] -> lift res
            z -> error $ "Overlapping routes: " ++ unlines (map show z)
    y = dataToPatQ (const Nothing) . resourcesFromString

-- | A quasi-quoter to parse the contents of a file into a list of 'Resource's. Checks for
-- overlapping routes, failing if present; use 'parseRoutesFileNoCheck' to skip the
-- checking
parseRoutesFile :: FilePath -> Q Exp
parseRoutesFile fp = do
    s <- qRunIO $ readUtf8File fp
    quoteExp parseRoutes s

-- | Same as 'parseRoutesFile', but performs no overlap checking.
parseRoutesFileNoCheck :: FilePath -> Q Exp
parseRoutesFileNoCheck fp = do
    s <- qRunIO $ readUtf8File fp
    quoteExp parseRoutesNoCheck s

readUtf8File :: FilePath -> IO String
readUtf8File fp = do
    h <- SIO.openFile fp SIO.ReadMode
    SIO.hSetEncoding h SIO.utf8_bom
    SIO.hGetContents h

-- | Same as 'parseRoutes', but performs no overlap checking.
parseRoutesNoCheck :: QuasiQuoter
parseRoutesNoCheck = QuasiQuoter
    { quoteExp = x
    , quotePat = y
    }
  where
    x = lift . resourcesFromString
    y = dataToPatQ (const Nothing) . resourcesFromString

instance Lift Resource where
    lift (Resource s ps h) = do
        r <- [|Resource|]
        s' <- lift s
        ps' <- lift ps
        h' <- lift h
        return $ r `AppE` s' `AppE` ps' `AppE` h'

-- | A single resource pattern.
--
-- First argument is the name of the constructor, second is the URL pattern to
-- match, third is how to dispatch.
data Resource = Resource String [Piece] [String]
    deriving (Read, Show, Eq, Data, Typeable)

-- | A single piece of a URL, delimited by slashes.
--
-- In the case of StaticPiece, the argument is the value of the piece; for the
-- other constructors, it is the name of the parameter represented by this
-- piece.
data Piece = StaticPiece String
           | SinglePiece String
           | MultiPiece String
    deriving (Read, Show, Eq, Data, Typeable)

instance Lift Piece where
    lift (StaticPiece s) = do
        c <- [|StaticPiece|]
        s' <- lift s
        return $ c `AppE` s'
    lift (SinglePiece s) = do
        c <- [|SinglePiece|]
        s' <- lift s
        return $ c `AppE` s'
    lift (MultiPiece s) = do
        c <- [|MultiPiece|]
        s' <- lift s
        return $ c `AppE` s'

resourcesFromString :: String -> [Resource]
resourcesFromString =
    mapMaybe go . lines
  where
    go s =
        case takeWhile (/= "--") $ words s of
            (pattern:constr:rest) ->
                let pieces = piecesFromString $ drop1Slash pattern
                 in Just $ Resource constr pieces rest
            [] -> Nothing
            _ -> error $ "Invalid resource line: " ++ s

drop1Slash :: String -> String
drop1Slash ('/':x) = x
drop1Slash x = x

piecesFromString :: String -> [Piece]
piecesFromString "" = []
piecesFromString x =
    let (y, z) = break (== '/') x
     in pieceFromString y : piecesFromString (drop1Slash z)

pieceFromString :: String -> Piece
pieceFromString ('#':x) = SinglePiece x
pieceFromString ('*':x) = MultiPiece x
pieceFromString x = StaticPiece x

-- n^2, should be a way to speed it up
findOverlaps :: [Resource] -> [(Resource, Resource)]
findOverlaps = go . map justPieces
  where
    justPieces :: Resource -> ([Piece], Resource)
    justPieces r@(Resource _ ps _) = (ps, r)

    go [] = []
    go (x:xs) = mapMaybe (mOverlap x) xs ++ go xs

    mOverlap :: ([Piece], Resource) -> ([Piece], Resource) ->
                Maybe (Resource, Resource)
    mOverlap (StaticPiece x:xs, xr) (StaticPiece y:ys, yr)
        | x == y = mOverlap (xs, xr) (ys, yr)
        | otherwise = Nothing
    mOverlap (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)
    mOverlap (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)
    mOverlap ([], xr) ([], yr) = Just (xr, yr)
    mOverlap ([], _) (_, _) = Nothing
    mOverlap (_, _) ([], _) = Nothing
    mOverlap (_:xs, xr) (_:ys, yr) = mOverlap (xs, xr) (ys, yr)