module Yesod.Raml.Routes.Internal where
import Control.Applicative
import Control.Monad
import qualified Data.Yaml as Y
import qualified Data.Yaml.Include as YI
import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import qualified Data.Char as C
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Yesod.Raml.Type
import Yesod.Raml.Parser()
import Text.Regex.Posix hiding (empty)
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Yesod.Routes.TH.Types
import Network.URI
routesFromRaml :: Raml -> Either String [RamlRoute]
routesFromRaml raml = do
let buri = T.replace "{version}" (version raml) (baseUri raml)
uripaths <- case parsePath buri of
(Just uri) -> return $ fmap ("/" <> ) $ T.split (== '/') $ if T.isPrefixOf "/" uri then T.tail uri else uri
Nothing -> Left $ "can not parse: " ++ (T.unpack buri)
v <- forM (M.toList (paths raml)) $ \(k,v) -> do
routesFromRamlResource v $ uripaths ++ [k]
return $ concat v
where
parsePath uri = fmap T.pack $ fmap uriPath $ parseURI (T.unpack uri)
routesFromRamlResource :: RamlResource -> [Path] -> Either String [RamlRoute]
routesFromRamlResource raml paths' = do
rrlist <- forM (M.toList (r_paths raml)) $ \(k,v) -> do
routesFromRamlResource v (paths' ++ [k])
let rlist = concat rrlist
case toHandler Nothing raml of
Right handle -> do
let methods = map fst $ M.toList (r_methods raml)
return $ (RamlRoute paths' handle methods):rlist
Left err -> do
case rrlist of
[] -> Left err
_ -> return rlist
toHandler :: Maybe HandlerHint -> RamlResource -> Either String Handler
toHandler mhint ramlMethod =
(fromHandlerTag ramlMethod) <|>
(fromDescription (fromMaybe "handler: *(.*)" mhint) ramlMethod)
where
fromHandlerTag :: RamlResource -> Either String Handler
fromHandlerTag ramlMethod' = do
handler <- case r_handler ramlMethod' of
Nothing -> Left "handler of method is empty"
(Just desc') -> return desc'
return handler
fromRegex :: T.Text -> T.Text -> Maybe T.Text
fromRegex pattern str =
let v = (T.unpack str) =~ (T.unpack pattern) :: (String,String,String,[String])
in case v of
(_,_,_,[]) -> Nothing
(_,_,_,h:_) -> Just $ T.pack h
fromDescription :: HandlerHint -> RamlResource -> Either String Handler
fromDescription hint ramlMethod' = do
desc <- case r_description ramlMethod' of
Nothing -> Left "Description of method is empty"
(Just desc') -> return desc'
case (foldr (<|>) empty $ map (fromRegex hint) $ T.lines $ desc) of
Nothing -> Left "Can not find Handler"
Just handler -> return handler
toYesodResource :: RamlRoute -> Resource String
toYesodResource route =
Resource {
resourceName = T.unpack (rr_handler route)
, resourcePieces = toPieces (rr_pieces route)
, resourceDispatch =
Methods {
methodsMulti = Nothing
, methodsMethods = map (T.unpack.T.toUpper) (rr_methods route)
}
, resourceAttrs = []
, resourceCheck = True
}
toRoutesFromString :: String -> [ResourceTree String]
toRoutesFromString ramlStr =
let eRaml = Y.decodeEither (B.pack ramlStr) :: Either String Raml
raml = case eRaml of
Right v -> v
Left e -> error $ "Invalid raml :" ++ e
routes = case (routesFromRaml raml) of
Right v -> v
Left e -> error $ "Invalid resource : " ++ e
in map ResourceLeaf $ map toYesodResource routes
toRoutesFromFile :: String -> IO [ResourceTree String]
toRoutesFromFile file = do
eRaml <- YI.decodeFileEither file
let raml = case eRaml of
Right v -> v
Left e -> error $ "Invalid raml :" ++ show e
routes = case (routesFromRaml raml) of
Right v -> v
Left e -> error $ "Invalid resource : " ++ e
return $ map ResourceLeaf $ map toYesodResource routes
capitalize :: String -> String
capitalize [] = []
capitalize (h:str) = C.toUpper h:str
toPiece :: T.Text -> Piece String
toPiece str | T.isPrefixOf "/{" str && T.isSuffixOf "}" str= Dynamic $ capitalize $ T.unpack $ T.takeWhile (/= '}') $ T.tail $ T.dropWhile (/= '{') str
| T.isPrefixOf "/" str = Static $ T.unpack $ T.tail str
| otherwise = error "Prefix is not '/'."
toPieces :: [Path] -> [Piece String]
toPieces paths' = map toPiece paths'
parseRamlRoutes :: QuasiQuoter
parseRamlRoutes = QuasiQuoter
{ quoteExp = lift . toRoutesFromString
, quotePat = undefined
, quoteType = undefined
, quoteDec = undefined
}
parseRamlRoutesFile :: FilePath -> Q Exp
parseRamlRoutesFile file = do
qAddDependentFile file
s <- qRunIO $ toRoutesFromFile file
lift s