├── .gitignore ├── README.md ├── cabal.project ├── example ├── backend │ ├── LICENSE │ ├── Setup.hs │ ├── app │ │ └── Main.hs │ └── backend.cabal ├── common │ ├── LICENSE │ ├── Setup.hs │ ├── common.cabal │ └── src │ │ └── Common.hs └── frontend │ ├── LICENSE │ ├── Setup.hs │ ├── app │ └── Main.hs │ ├── frontend.cabal │ └── semantic.min.css ├── trasa-client ├── LICENSE ├── Setup.hs ├── src │ └── Trasa │ │ ├── Client.hs │ │ └── Client │ │ └── Implicit.hs ├── test │ └── Main.hs └── trasa-client.cabal ├── trasa-init ├── LICENSE ├── Setup.hs ├── app │ └── Main.hs ├── changelog.md ├── readme.md ├── res │ ├── nixpkgs.json │ ├── pinned-nixpkgs.nix │ ├── trasa-client.nix │ ├── trasa-server.nix │ └── trasa.nix └── trasa-init.cabal ├── trasa-reflex ├── ChangeLog.md ├── LICENSE ├── Setup.hs ├── cachix.sh ├── src │ ├── Reflex │ │ └── PopState.hs │ └── Trasa │ │ ├── Reflex.hs │ │ └── Reflex │ │ └── Implicit.hs └── trasa-reflex.cabal ├── trasa-server ├── LICENSE ├── Setup.hs ├── src │ └── Trasa │ │ ├── Server.hs │ │ └── Server │ │ └── Implicit.hs ├── test │ └── Main.hs └── trasa-server.cabal ├── trasa-th ├── LICENSE ├── Setup.hs ├── src │ └── Trasa │ │ ├── TH.hs │ │ └── TH │ │ ├── Lexer.hs │ │ ├── Parse.hs │ │ └── Types.hs ├── test │ └── Main.hs └── trasa-th.cabal ├── trasa-tutorial ├── LICENSE ├── Setup.hs ├── cachix.sh ├── src │ └── Trasa │ │ └── Tutorial.hs └── trasa-tutorial.cabal └── trasa ├── LICENSE ├── Setup.hs ├── cachix.sh ├── src └── Trasa │ ├── Codec.hs │ ├── Core.hs │ ├── Core │ └── Implicit.hs │ ├── Error.hs │ ├── Method.hs │ ├── Tutorial.hs │ └── Url.hs ├── test ├── Doctest.hs └── Main.hs └── trasa.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | _darcs/ 2 | sites/ 3 | dist* 4 | playground/ 5 | upload/ 6 | static/tmp/ 7 | static/uploads/ 8 | .stack-work/ 9 | static/tmp/ 10 | static/combined/ 11 | config/client_session_key.aes 12 | *.hi 13 | *.o 14 | *.sqlite3 15 | .hsenv* 16 | cabal-dev/ 17 | yesod-devel/ 18 | .cabal-sandbox 19 | cabal.sandbox.config 20 | .DS_Store 21 | *.swp 22 | scripts/package 23 | scripts/package.tar.xz 24 | tmp_client_codes.txt 25 | trasa-reflex/result 26 | example/frontend/result 27 | example/common/result 28 | result 29 | .ghc* 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # trasa 2 | 3 | This library is a solution for http-based routing and dispatch. Its goals are similar to the goals of servant, however, trasa relies on very different mechanisms to accomplish those goals. All typeclasses in this library are optional. All of the real work is accomplished with GADTs, universal quantification, and plain old haskell data types. 4 | 5 | An example application featuring server and client can be seen in the [example folder](./example/). 6 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | trasa/ 3 | trasa-client/ 4 | trasa-init/ 5 | trasa-server/ 6 | trasa-th/ 7 | -------------------------------------------------------------------------------- /example/backend/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017-2019 Andrew Martin 2 | Copyright 2017-2019 Kyle McKean 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 5 | 6 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 9 | -------------------------------------------------------------------------------- /example/backend/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/backend/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | 8 | module Main where 9 | 10 | import Common 11 | import Control.Concurrent.STM 12 | import Control.Monad.Except (throwError) 13 | import Control.Monad.IO.Class (liftIO) 14 | import Data.Functor.Identity (Identity(..)) 15 | import Network.Wai (Application) 16 | import Network.Wai.Handler.Warp (run) 17 | import Network.Wai.Middleware.RequestLogger (logStdoutDev) 18 | import Topaz.Rec (Rec(..)) 19 | import Trasa.Core 20 | import Trasa.Server 21 | import qualified Data.Map.Strict as M 22 | import qualified Network.HTTP.Types.Status as S 23 | 24 | routes 25 | :: forall cs qs rq rp 26 | . TVar (M.Map Key Person) 27 | -> Route cs qs rq rp 28 | -> Rec Identity cs 29 | -> Rec Parameter qs 30 | -> RequestBody Identity rq 31 | -> TrasaT IO rp 32 | routes database route captures querys reqBody = case route of 33 | AddR -> go handleAddR 34 | EditR -> go handleEditR 35 | DeleteR -> go handleDeleteR 36 | ViewR -> go handleViewR 37 | ViewAllR -> go handleViewAllR 38 | where 39 | go :: (TVar (M.Map Key Person) -> Arguments cs qs rq (TrasaT IO rp)) -> TrasaT IO rp 40 | go f = handler captures querys reqBody (f database) 41 | 42 | handleAddR :: TVar (M.Map Key Person) -> Person -> TrasaT IO Key 43 | handleAddR database person = liftIO . atomically $ do 44 | m <- readTVar database 45 | let newKey = case M.maxViewWithKey m of 46 | Just ((k,_),_) -> succ k 47 | Nothing -> Key 0 48 | writeTVar database (M.insert newKey person m) 49 | return newKey 50 | 51 | handleEditR :: TVar (M.Map Key Person) -> Key -> Person -> TrasaT IO () 52 | handleEditR database k person = liftIO . atomically $ do 53 | m <- readTVar database 54 | writeTVar database (M.insert k person m) 55 | 56 | handleDeleteR :: TVar (M.Map Key Person) -> Key -> TrasaT IO () 57 | handleDeleteR database k = liftIO . atomically $ do 58 | m <- readTVar database 59 | writeTVar database (M.delete k m) 60 | 61 | handleViewR :: TVar (M.Map Key Person) -> Key -> TrasaT IO Person 62 | handleViewR database k = do 63 | m <- liftIO (readTVarIO database) 64 | case M.lookup k m of 65 | Just person -> return person 66 | Nothing -> throwError (TrasaErr S.status404 "Person not found") 67 | 68 | handleViewAllR :: TVar (M.Map Key Person) -> Maybe Int -> TrasaT IO [Keyed Person] 69 | handleViewAllR database limit = liftIO . atomically $ do 70 | m <- readTVar database 71 | (return . fmap (uncurry Keyed) . maybe id take limit . M.toList) m 72 | 73 | router :: Router Route 74 | router = routerWith (mapMeta captureDecoding captureDecoding id id . meta) allRoutes 75 | 76 | application :: TVar (M.Map Key Person) -> Application 77 | application database = serveWith 78 | (metaCodecToMetaServer . meta) 79 | (routes database) 80 | router 81 | 82 | -- | Example usage: 83 | -- > curl -v -H 'Content-Type:text/haskell' -X PUT 127.0.0.1:8080/edit/1 -d 'Person { personAge=5,personName="Bob" }' 84 | main :: IO () 85 | main = do 86 | database <- newTVarIO (M.fromList people) 87 | (run 8080 . logStdoutDev . application) database 88 | where people = [(Key 0, Person 18 "Kyle"),(Key 1, Person 25 "Drew")] 89 | -------------------------------------------------------------------------------- /example/backend/backend.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: 3 | backend 4 | version: 5 | 0.1 6 | synopsis: 7 | backend for the trasa example 8 | homepage: 9 | https://github.com/haskell-trasa/trasa 10 | author: 11 | Andrew Martin 12 | Kyle McKean 13 | maintainer: 14 | Andrew Martin 15 | Kyle McKean 16 | chessai 17 | license: 18 | MIT 19 | license-file: 20 | LICENSE 21 | copyright: 22 | © 2017-2019 Andrew Martin 23 | © 2017-2019 Kyle McKean 24 | category: 25 | Web 26 | build-type: 27 | Simple 28 | 29 | executable backend 30 | hs-source-dirs: 31 | app 32 | main-is: 33 | Main.hs 34 | build-depends: 35 | , base >=4.9 && <5.0 36 | , common 37 | , containers >= 0.5 && < 0.7 38 | , http-types >= 0.9 && < 0.13 39 | , mtl == 2.2.* 40 | , quantification == 0.5.0 41 | , stm >= 2.4 && < 2.6 42 | , trasa == 0.4 43 | , trasa-server == 0.4 44 | , wai == 3.2.* 45 | , wai-extra == 3.0.* 46 | , warp == 3.2.* 47 | default-language: 48 | Haskell2010 49 | -------------------------------------------------------------------------------- /example/common/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017-2019 Andrew Martin 2 | Copyright 2017-2019 Kyle McKean 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 5 | 6 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 9 | -------------------------------------------------------------------------------- /example/common/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/common/common.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: 3 | common 4 | version: 5 | 0.1 6 | synopsis: 7 | Common code for the trasa example's backend/frontend 8 | homepage: 9 | https://github.com/haskell-trasa/trasa 10 | author: 11 | Andrew Martin 12 | Kyle McKean 13 | maintainer: 14 | Andrew Martin 15 | Kyle McKean 16 | chessai 17 | license: 18 | MIT 19 | license-file: 20 | LICENSE 21 | copyright: 22 | © 2017-2019 Andrew Martin 23 | © 2017-2019 Kyle McKean 24 | category: 25 | Web 26 | build-type: 27 | Simple 28 | 29 | library 30 | hs-source-dirs: 31 | src 32 | exposed-modules: 33 | Common 34 | build-depends: 35 | , base >=4.9 && < 5.0 36 | , bytestring == 0.10.* 37 | , text == 1.2.* 38 | , quantification == 0.5.0 39 | , trasa == 0.4 40 | default-language: 41 | Haskell2010 42 | -------------------------------------------------------------------------------- /example/common/src/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | 8 | module Common where 9 | 10 | import Data.List.NonEmpty (NonEmpty(..)) 11 | import Data.Bifunctor (first) 12 | import Data.Kind (Type) 13 | import Topaz.Rec (Rec) 14 | import Trasa.Core 15 | import qualified Data.Text as T 16 | import qualified Trasa.Method as M 17 | 18 | newtype Key = Key Int deriving (Enum, Eq, Ord) 19 | 20 | instance Show Key where 21 | show (Key i) = show i 22 | 23 | instance Read Key where 24 | readsPrec p = fmap (first Key) . readsPrec p 25 | 26 | data Keyed a = Keyed 27 | { keyedKey :: Key 28 | , keyedValue :: a 29 | } deriving (Show, Read) 30 | 31 | data Person = Person 32 | { personAge :: Int 33 | , personName :: T.Text 34 | } deriving (Show, Read) 35 | 36 | data Route :: [Type] -> [Param] -> Bodiedness -> Type -> Type where 37 | AddR :: Route '[] '[] (Body Person) Key 38 | EditR :: Route '[Key] '[] (Body Person) () 39 | DeleteR :: Route '[Key] '[] Bodyless () 40 | ViewR :: Route '[Key] '[] Bodyless Person 41 | ViewAllR :: Route '[] '[Optional Int] Bodyless [Keyed Person] 42 | 43 | meta :: Route caps qrys req resp -> MetaCodec caps qrys req resp 44 | meta = \case 45 | AddR -> Meta (match "add" ./ end) qend (body $ one bodyPerson) (resp $ one bodyKey) M.post 46 | EditR -> Meta (match "edit" ./ capture key ./ end) qend (body $ one bodyPerson) (resp $ one bodyUnit) M.put 47 | DeleteR -> Meta (match "delete" ./ capture key ./ end) qend bodyless (resp $ one bodyUnit) M.delete 48 | ViewR -> Meta (match "view" ./ capture key ./ end) qend bodyless (resp $ one bodyPerson) M.get 49 | ViewAllR -> Meta (match "view-all" ./ end) (optional "limit" int .& qend) bodyless (resp $ one bodyKeyed) M.get 50 | 51 | key :: CaptureCodec Key 52 | key = showReadCaptureCodec 53 | 54 | int :: CaptureCodec Int 55 | int = showReadCaptureCodec 56 | 57 | bodyKey :: BodyCodec Key 58 | bodyKey = showReadBodyCodec 59 | 60 | bodyKeyed :: (Show a, Read a) => BodyCodec [Keyed a] 61 | bodyKeyed = showReadBodyCodec 62 | 63 | bodyPerson :: BodyCodec Person 64 | bodyPerson = showReadBodyCodec 65 | 66 | bodyUnit :: BodyCodec () 67 | bodyUnit = BodyCodec (pure "text/plain") (const "") (const (Right ())) 68 | 69 | allRoutes :: [Constructed Route] 70 | allRoutes = [Constructed AddR, Constructed EditR, Constructed DeleteR, Constructed ViewR, Constructed ViewAllR] 71 | 72 | prepare :: Route cs qs rq rp -> Arguments cs qs rq (Prepared Route rp) 73 | prepare = prepareWith meta 74 | 75 | link :: Prepared Route rp -> Url 76 | link = linkWith (mapMeta captureEncoding captureEncoding id id . meta) 77 | -------------------------------------------------------------------------------- /example/frontend/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017-2019 Andrew Martin 2 | Copyright 2017-2019 Kyle McKean 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 5 | 6 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 9 | -------------------------------------------------------------------------------- /example/frontend/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/frontend/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Main where 5 | 6 | import Data.FileEmbed (embedFile) 7 | import Common 8 | import Trasa.Core (metaCodecToMetaClient) 9 | import Trasa.Error 10 | import Trasa.Client 11 | import Network.HTTP.Client 12 | 13 | --css :: Text 14 | --css = $(embedFile "semantic.min.css") 15 | 16 | scheme :: Scheme 17 | scheme = Http 18 | 19 | authority :: Authority 20 | authority = Authority scheme "127.0.0.1" Nothing 21 | 22 | config :: IO Config 23 | config = do 24 | mngr <- newManager defaultManagerSettings 25 | pure $ Config authority mempty mngr 26 | 27 | client :: IO (Either TrasaErr resp) 28 | client = do 29 | cfg <- config 30 | clientWith (metaCodecToMetaClient . meta) cfg _ 31 | 32 | main :: IO () 33 | main = pure () 34 | -------------------------------------------------------------------------------- /example/frontend/frontend.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: 3 | frontend 4 | version: 5 | 0.1 6 | synopsis: 7 | frontend for the trasa example 8 | homepage: 9 | https://github.com/haskell-trasa/trasa 10 | author: 11 | Andrew Martin 12 | Kyle McKean 13 | maintainer: 14 | Andrew Martin 15 | Kyle McKean 16 | chessai 17 | license: 18 | MIT 19 | license-file: 20 | LICENSE 21 | copyright: 22 | © 2017-2019 Andrew Martin 23 | © 2017-2019 Kyle McKean 24 | category: 25 | Web 26 | build-type: 27 | Simple 28 | 29 | executable frontend 30 | hs-source-dirs: 31 | app 32 | main-is: 33 | Main.hs 34 | build-depends: 35 | , base >= 4.9 && < 5 36 | , file-embed == 0.0.* 37 | , common 38 | , http-client 39 | , trasa == 0.4 40 | , trasa-client == 0.4 41 | default-language: 42 | Haskell2010 43 | -------------------------------------------------------------------------------- /trasa-client/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017-2019 Andrew Martin 2 | Copyright 2017-2019 Kyle McKean 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 5 | 6 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 9 | -------------------------------------------------------------------------------- /trasa-client/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /trasa-client/src/Trasa/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | module Trasa.Client 6 | ( 7 | -- * Types 8 | Scheme(..) 9 | , Authority(..) 10 | , Config(..) 11 | -- * Requests 12 | , clientWith 13 | , routeToRequest 14 | ) where 15 | 16 | import Data.Maybe (fromMaybe) 17 | import Data.Word (Word16) 18 | import qualified Data.List.NonEmpty as NE 19 | import qualified Data.ByteString as BS 20 | import qualified Data.ByteString.Lazy as LBS 21 | import qualified Data.Binary.Builder as LBS 22 | import qualified Data.Text as T 23 | import qualified Data.Text.Encoding as TE 24 | import qualified Data.Text.Lazy as LT hiding (singleton) 25 | import qualified Data.Text.Lazy.Builder as LT 26 | import qualified Data.Text.Lazy.Builder.Int as LT 27 | import qualified Data.Map.Strict as M 28 | import Data.CaseInsensitive (CI) 29 | import qualified Network.HTTP.Types.URI as N 30 | import qualified Network.HTTP.Types.Header as N 31 | import qualified Network.HTTP.Types.Status as N 32 | import qualified Network.HTTP.Media as N 33 | import qualified Network.HTTP.Client as N 34 | 35 | import Trasa.Core hiding (status,body) 36 | 37 | -- | If you select Https you need to pass in a tls manager in config or tls wont actually happen 38 | data Scheme = Http | Https 39 | 40 | schemeToSecure :: Scheme -> Bool 41 | schemeToSecure = \case 42 | Http -> False 43 | Https -> True 44 | 45 | schemeToPort :: Scheme -> Int 46 | schemeToPort = \case 47 | Http -> 80 48 | Https -> 443 49 | 50 | data Authority = Authority 51 | { authorityScheme :: !Scheme 52 | , authorityHost :: !T.Text 53 | , authorityPort :: !(Maybe Word16) 54 | } 55 | 56 | encodeAuthority :: T.Text -> Maybe Word16 -> BS.ByteString 57 | encodeAuthority host port = 58 | (TE.encodeUtf8 . LT.toStrict . LT.toLazyText) 59 | (LT.fromText host <> maybe "" (\p -> LT.singleton ':' <> LT.decimal p) port) 60 | 61 | encodePathBS :: [T.Text] -> BS.ByteString 62 | encodePathBS = LBS.toStrict . LBS.toLazyByteString . (LBS.putCharUtf8 '/' <>) . N.encodePathSegmentsRelative 63 | 64 | encodeQueryBS :: QueryString -> BS.ByteString 65 | encodeQueryBS = 66 | LBS.toStrict . 67 | LBS.toLazyByteString . 68 | N.renderQueryBuilder True . 69 | encodeQuery 70 | 71 | encodeAcceptBS :: NE.NonEmpty N.MediaType -> BS.ByteString 72 | encodeAcceptBS = BS.intercalate "; " . fmap N.renderHeader . NE.toList 73 | 74 | encodeHeaders 75 | :: NE.NonEmpty N.MediaType 76 | -> Maybe Content 77 | -> M.Map (CI BS.ByteString) T.Text 78 | -> [(CI BS.ByteString,BS.ByteString)] 79 | encodeHeaders accepts mcontent = 80 | M.toList . 81 | M.insert N.hAccept (encodeAcceptBS accepts) . 82 | maybe id (M.insert N.hContentType . N.renderHeader . fromMaybe (NE.head accepts) . contentType) mcontent . 83 | fmap TE.encodeUtf8 84 | 85 | data Config = Config 86 | { configAuthority :: !Authority 87 | , configHeaders :: !(M.Map (CI BS.ByteString) T.Text) 88 | , configManager :: !N.Manager 89 | } 90 | 91 | clientWith 92 | :: forall route response 93 | . (forall caps qrys req resp. route caps qrys req resp -> MetaClient caps qrys req resp) 94 | -> Config 95 | -> Prepared route response 96 | -- ^ Which endpoint to request 97 | -> IO (Either TrasaErr response) 98 | clientWith toMeta config = 99 | requestWith toMeta run 100 | where 101 | run :: Method -> Url -> Maybe Content -> NE.NonEmpty N.MediaType -> IO (Either TrasaErr Content) 102 | run method url mcontent accepts = do 103 | response <- N.httpLbs req (configManager config) 104 | let status = N.responseStatus response 105 | body = N.responseBody response 106 | return $ case status < N.status400 of 107 | True -> case lookup N.hContentType (N.responseHeaders response) of 108 | Nothing -> Right (Content Nothing body) 109 | Just bs -> case N.parseAccept bs of 110 | Nothing -> Left (TrasaErr N.status415 "Could not decode content type") 111 | Just typ -> Right (Content (Just typ) body) 112 | False -> Left (TrasaErr status body) 113 | where 114 | req = mkRequest config method url mcontent accepts 115 | 116 | mkRequest :: Config -> Method -> Url -> Maybe Content -> NE.NonEmpty N.MediaType -> N.Request 117 | mkRequest config method (Url path query) mcontent accepts = 118 | N.defaultRequest 119 | { N.method = TE.encodeUtf8 $ encodeMethod method 120 | , N.secure = schemeToSecure scheme 121 | , N.host = encodeAuthority host port 122 | , N.port = maybe (schemeToPort scheme) fromIntegral port 123 | , N.path = encodePathBS path 124 | , N.queryString = encodeQueryBS query 125 | , N.requestHeaders = encodeHeaders accepts mcontent headers 126 | , N.requestBody = case mcontent of 127 | Nothing -> N.RequestBodyLBS "" 128 | Just (Content _ reqBody) -> N.RequestBodyLBS reqBody 129 | } 130 | where 131 | Config (Authority scheme host port) headers _ = config 132 | 133 | routeToRequest 134 | :: Config 135 | -> (forall caps qrys req resp. route caps qrys req resp -> MetaClient caps qrys req resp) 136 | -> Prepared route response 137 | -> N.Request 138 | routeToRequest config toMeta (Prepared route captures querys reqBody) = 139 | mkRequest config method url content accepts 140 | where 141 | m = toMeta route 142 | method = metaMethod m 143 | url = encodeUrlPieces (metaPath m) (metaQuery m) captures querys 144 | content = encodeRequestBody (metaRequestBody m) reqBody 145 | ResponseBody (Many decodings) = metaResponseBody m 146 | accepts = bodyDecodingNames =<< decodings 147 | 148 | -------------------------------------------------------------------------------- /trasa-client/src/Trasa/Client/Implicit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Trasa.Client.Implicit where 5 | 6 | import Trasa.Core 7 | import Trasa.Core.Implicit 8 | import Trasa.Client 9 | 10 | client 11 | :: ( HasMeta route 12 | , HasCaptureEncoding (CaptureStrategy route) 13 | , HasCaptureEncoding (QueryStrategy route) 14 | , RequestBodyStrategy route ~ Many requestBodyStrat 15 | , HasBodyEncoding requestBodyStrat 16 | , ResponseBodyStrategy route ~ Many responseBodyStrat 17 | , HasBodyDecoding responseBodyStrat 18 | ) 19 | => Config 20 | -> Prepared route response 21 | -> IO (Either TrasaErr response) 22 | client = clientWith (transformMeta . meta) 23 | where transformMeta = mapMeta captureEncoding captureEncoding (mapMany bodyEncoding) (mapMany bodyDecoding) 24 | 25 | 26 | -------------------------------------------------------------------------------- /trasa-client/test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE InstanceSigs #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveAnyClass #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE DataKinds #-} 9 | {-# LANGUAGE KindSignatures #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# OPTIONS_GHC -Wall -Werror -Wno-unticked-promoted-constructors #-} 12 | module Main where 13 | 14 | import Data.Kind (Type) 15 | import GHC.Generics hiding (Meta) 16 | import Data.Bifunctor (Bifunctor(..)) 17 | import qualified Data.HashMap.Strict as H 18 | import qualified Data.Text as T 19 | import Data.Aeson 20 | (Value(..),FromJSON(..),ToJSON(..),encode,eitherDecode' 21 | ,object,withObject,(.:),(.=)) 22 | import Net.Types (IPv4) 23 | import Control.Exception (catch,SomeException) 24 | import System.Exit (exitFailure) 25 | import qualified Network.HTTP.Types.Status as N 26 | import qualified Network.HTTP.Client as N 27 | import Trasa.Core 28 | import Trasa.Core.Implicit 29 | import qualified Trasa.Method as M 30 | import Trasa.Client 31 | import Trasa.Client.Implicit 32 | 33 | data Ip = Ip 34 | { origin :: IPv4 35 | } deriving (Generic,FromJSON,ToJSON) 36 | 37 | instance Show Ip where 38 | show (Ip ipv4) = "{ origin: " ++ show ipv4 ++ " }" 39 | 40 | data Args = Args 41 | { args :: H.HashMap T.Text Value 42 | } deriving Show 43 | 44 | instance FromJSON Args where 45 | parseJSON = withObject "Args" $ \o -> Args <$> o .: "args" 46 | 47 | instance ToJSON Args where 48 | toJSON (Args as) = object [ "args" .= as ] 49 | 50 | bodyAeson :: (FromJSON a, ToJSON a) => BodyCodec a 51 | bodyAeson = BodyCodec (pure "application/json") encode (first T.pack . eitherDecode') 52 | 53 | int :: CaptureCodec Int 54 | int = showReadCaptureCodec 55 | 56 | bodyUnit :: BodyCodec () 57 | bodyUnit = BodyCodec (pure "text/html") (const "") (const (Right ())) 58 | 59 | data Route :: [Type] -> [Param] -> Bodiedness -> Type -> Type where 60 | RouteHome :: Route '[] '[] Bodyless () 61 | RouteIp :: Route '[] '[] Bodyless Ip 62 | RouteStatus :: Route '[Int] '[] Bodyless () 63 | RouteQuery :: Route '[] '[Optional Int] Bodyless Args 64 | 65 | instance HasMeta Route where 66 | type CaptureStrategy Route = CaptureCodec 67 | type QueryStrategy Route = CaptureCodec 68 | type RequestBodyStrategy Route = Many BodyCodec 69 | type ResponseBodyStrategy Route = Many BodyCodec 70 | meta :: Route caps qrys req resp -> MetaCodec caps qrys req resp 71 | meta route = metaBuilderToMetaCodec $ case route of 72 | RouteHome -> Meta end qend bodyless (resp bodyUnit) M.get 73 | RouteIp -> Meta (match "ip" ./ end) qend bodyless (resp bodyAeson) M.get 74 | RouteStatus -> Meta (match "status" ./ capture int ./ end) qend bodyless (resp bodyUnit) M.get 75 | RouteQuery -> Meta (match "anything" ./ end) (optional "int" int .& qend) bodyless (resp bodyAeson) M.get 76 | 77 | shouldRight :: Show resp => Config -> Prepared Route resp -> IO () 78 | shouldRight conf route = do 79 | putStr $ show (link route) ++ ": " 80 | client conf route >>= \case 81 | Left err -> do 82 | print err 83 | exitFailure 84 | Right val -> print val 85 | 86 | main :: IO () 87 | main = do 88 | manager <- N.newManager N.defaultManagerSettings 89 | let conf = Config (Authority Http "httpbin.org" Nothing) mempty manager 90 | res <- catch (client conf (prepare RouteHome)) $ \(_ :: SomeException) -> return (Left (status N.status400)) 91 | case res of 92 | Left err -> do 93 | putStrLn "Could not connect to httpbin.org, not running test suite" 94 | putStrLn ("Could not connect because: " ++ show err) 95 | Right _ -> do 96 | putStrLn "Connected to httpbin.org, actually testing routes now..." 97 | shouldRight conf (prepare RouteIp) 98 | shouldRight conf (prepare RouteStatus 200) 99 | shouldRight conf (prepare RouteQuery (Just 1)) 100 | -------------------------------------------------------------------------------- /trasa-client/trasa-client.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: 3 | trasa-client 4 | version: 5 | 0.4 6 | synopsis: 7 | Type safe http requests 8 | description: 9 | http-client integration for trasa 10 | homepage: 11 | https://github.com/haskell-trasa/trasa 12 | author: 13 | Andrew Martin 14 | Kyle McKean 15 | maintainer: 16 | Andrew Martin 17 | Kyle McKean 18 | chessai 19 | license: 20 | MIT 21 | license-file: 22 | LICENSE 23 | copyright: 24 | © 2017-2019 Andrew Martin 25 | © 2017-2019 Kyle McKean 26 | category: 27 | Web 28 | build-type: 29 | Simple 30 | 31 | library 32 | hs-source-dirs: 33 | src 34 | exposed-modules: 35 | Trasa.Client 36 | Trasa.Client.Implicit 37 | build-depends: 38 | , base >= 4.9 && < 5 39 | , binary >= 0.8 && < 0.9 40 | , bytestring >= 0.10 && < 0.11 41 | , case-insensitive >= 1.2 && < 1.3 42 | , containers >= 0.5 && < 0.7 43 | , http-client >= 0.5 && < 0.7 44 | , http-media >= 0.6 && < 0.9 45 | , http-types >= 0.9 && < 0.13 46 | , text >= 1.2 && < 1.3 47 | , trasa >= 0.4 && < 0.5 48 | default-language: 49 | Haskell2010 50 | ghc-options: 51 | -Wall -O2 52 | 53 | --test-suite test 54 | -- type: exitcode-stdio-1.0 55 | -- hs-source-dirs: test 56 | -- main-is: Main.hs 57 | -- build-depends: base >= 4.9 && < 5 58 | -- , trasa 59 | -- , trasa-client 60 | -- , http-types 61 | -- , http-client 62 | -- , unordered-containers 63 | -- , text 64 | -- , ip 65 | -- , aeson 66 | -- ghc-options: -threaded -rtsopts -with-rtsopts=-N 67 | -- default-language: Haskell2010 68 | 69 | source-repository head 70 | type: git 71 | location: https://github.com/haskell-trasa/trasa 72 | -------------------------------------------------------------------------------- /trasa-init/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2020 chessai 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 8 | -------------------------------------------------------------------------------- /trasa-init/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /trasa-init/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# language 2 | LambdaCase 3 | , OverloadedStrings 4 | , TemplateHaskell 5 | #-} 6 | 7 | module Main (main) where 8 | 9 | import Data.FileEmbed (embedStringFile) 10 | import Data.Foldable (for_) 11 | import Data.List (intercalate) 12 | import System.Directory (createDirectoryIfMissing, withCurrentDirectory) 13 | import System.Environment (getArgs) 14 | 15 | main :: IO () 16 | main = getArgs >>= \case 17 | [] -> do 18 | help 19 | ["--help"] -> do 20 | help 21 | [name] -> do 22 | write (project name) 23 | _ -> do 24 | help 25 | 26 | help :: IO () 27 | help = do 28 | let msg = "" 29 | <> "trasa-init: initialise a trasa project\n\n" 30 | <> "usage: trasa-init \n" 31 | putStrLn msg 32 | 33 | -- | Simple file system tree structure. 34 | data TreeFs 35 | = Dir FilePath [TreeFs] 36 | -- ^ Name of directory (relative) and 37 | -- its containing entries 38 | | File FilePath String 39 | -- ^ File name (relative) and file content 40 | 41 | write :: TreeFs -> IO () 42 | write = \case 43 | File name content -> do 44 | writeFile name (content <> "\n") 45 | Dir name children -> do 46 | createDirectoryIfMissing False name 47 | withCurrentDirectory name $ for_ children write 48 | 49 | language_ :: String -> String 50 | language_ p = "{-# LANGUAGE " <> p <> " #-}" 51 | 52 | module_ :: String -> [String] -> String 53 | module_ m is = "module " <> m <> "\n" <> unlines (go is) 54 | where 55 | go :: [String] -> [String] 56 | go [] = [" (\n ) where"] 57 | go (x:xs) = map showExportLine 58 | (LeftParen x : (map Comma xs ++ [End])) 59 | 60 | data ExportLine = LeftParen String | Comma String | End 61 | 62 | showExportLine :: ExportLine -> String 63 | showExportLine = \case 64 | LeftParen i -> " ( " <> i 65 | Comma i -> " , " <> i 66 | End -> " ) where" 67 | 68 | import_ :: String -> Maybe [String] -> String 69 | import_ m Nothing = "import " <> m 70 | import_ m (Just is) = "import " <> m <> " (" <> intercalate ", " is <> ")" 71 | 72 | importQ_ :: String -> Maybe String -> String 73 | importQ_ m Nothing = "import qualified " <> m 74 | importQ_ m (Just q) = "import qualified " <> m <> " as " <> q 75 | 76 | project :: String -> TreeFs 77 | project name = Dir name 78 | [ File (name <> ".cabal") (cabalFile name) 79 | , Dir "src" 80 | [ client 81 | , common 82 | , server 83 | ] 84 | , Dir "app" 85 | [ File "Main.hs" $ unlines 86 | [ "module Main (main) where" 87 | , "" 88 | , "import qualified Server" 89 | , "" 90 | , "main :: IO ()" 91 | , "main = Server.main" 92 | ] 93 | ] 94 | , defaultNix name 95 | , shellNix name 96 | , Dir ".nix" 97 | [ File "nixpkgs.json" $(embedStringFile "./res/nixpkgs.json") 98 | , File "pinned-nixpkgs.nix" $(embedStringFile "./res/pinned-nixpkgs.nix") 99 | , File "trasa.nix" $(embedStringFile "./res/trasa.nix") 100 | , File "trasa-client.nix" $(embedStringFile "./res/trasa-client.nix") 101 | , File "trasa-server.nix" $(embedStringFile "./res/trasa-server.nix") 102 | ] 103 | , File "Makefile" $ unlines 104 | [ "package = " <> name 105 | , "" 106 | , "build:" 107 | , "\tcabal build" 108 | , "" 109 | , "clean:" 110 | , "\tcabal clean" 111 | , "" 112 | , "haddock:" 113 | , "\tcabal haddock" 114 | , "" 115 | , "ghci:" 116 | , "\tcabal repl" 117 | , "" 118 | , "ghcid:" 119 | , "\tghcid -c cabal repl -r \"Server.main\"" 120 | ] 121 | ] 122 | 123 | client :: TreeFs 124 | client = File "Client.hs" $ unlines 125 | [ language_ "OverloadedStrings" 126 | , "" 127 | , module_ "Client" ["helloWorld"] 128 | , import_ "Lucid" Nothing 129 | , import_ "Data.IORef" (Just ["IORef", "newIORef", "readIORef"]) 130 | , import_ "Network.HTTP.Client" (Just ["newManager", "defaultManagerSettings"]) 131 | , import_ "Trasa.Core" Nothing 132 | , import_ "Trasa.Client" (Just ["Scheme(..)", "Authority(..)", "Config(..)", "clientWith"]) 133 | , import_ "System.IO.Unsafe" (Just ["unsafePerformIO"]) 134 | , "" 135 | , import_ "Common" Nothing 136 | , "" 137 | , "scheme :: Scheme" 138 | , "scheme = Http" 139 | , "" 140 | , "authority :: Authority" 141 | , "authority = Authority scheme \"127.0.0.1\" (Just 8080)" 142 | , "" 143 | , "config :: IORef Config" 144 | , "config = unsafePerformIO $ do" 145 | , " mngr <- newManager defaultManagerSettings" 146 | , " newIORef (Config authority mempty mngr)" 147 | , "{-# NOINLINE config #-}" 148 | , "" 149 | , "client :: Prepared Route response -> IO (Either TrasaErr response)" 150 | , "client p = do" 151 | , " cfg <- readIORef config" 152 | , " clientWith (metaCodecToMetaClient . meta) cfg p" 153 | , "" 154 | , "prepare :: ()" 155 | , " => Route captures queries request response" 156 | , " -> Arguments captures queries request (Prepared Route response)" 157 | , "prepare = prepareWith meta" 158 | , "" 159 | , "helloWorld :: IO (Either TrasaErr (Html ()))" 160 | , "helloWorld = client $ prepare HelloWorld" 161 | ] 162 | 163 | common :: TreeFs 164 | common = File "Common.hs" $ unlines 165 | [ language_ "DataKinds" 166 | , language_ "GADTs" 167 | , language_ "KindSignatures" 168 | , language_ "LambdaCase" 169 | , language_ "OverloadedStrings" 170 | , language_ "TemplateHaskell" 171 | , "" 172 | , module_ "Common" 173 | [ "Route(..)" 174 | , "allRoutes" 175 | , "meta" 176 | ] 177 | , import_ "Data.Kind" (Just ["Type"]) 178 | , import_ "Data.String" (Just ["fromString"]) 179 | , import_ "Lucid" Nothing 180 | , import_ "Trasa.Core" Nothing 181 | , importQ_ "Data.ByteString.Lazy.Char8" (Just "BC8") 182 | , importQ_ "Trasa.Method" (Just "Method") 183 | , "" 184 | , "data Route :: [Type] -> [Param] -> Bodiedness -> Type -> Type where" 185 | , " HelloWorld :: Route '[] '[] 'Bodyless (Html ())" 186 | , "" 187 | , "meta :: ()" 188 | , " => Route captures queries request response" 189 | , " -> MetaCodec captures queries request response" 190 | , "meta = \\case" 191 | , " HelloWorld -> Meta (match \"hello\" ./ end) qend bodyless (resp (one bodyHtml)) Method.get" 192 | , "" 193 | , "bodyHtml :: BodyCodec (Html ())" 194 | , "bodyHtml = BodyCodec" 195 | , " (pure \"text/html\")" 196 | , " Lucid.renderBS" 197 | , " (Right . fromString . BC8.unpack)" 198 | , "" 199 | , "-- Generate all of our routes" 200 | , "$(generateAllRoutes ''Route)" 201 | ] 202 | 203 | server :: TreeFs 204 | server = File "Server.hs" $ unlines 205 | [ language_ "DataKinds" 206 | , language_ "GADTs" 207 | , language_ "KindSignatures" 208 | , language_ "LambdaCase" 209 | , language_ "OverloadedStrings" 210 | , language_ "ScopedTypeVariables" 211 | , "" 212 | , module_ "Server" ["main"] 213 | , import_ "Data.Functor.Identity" (Just ["Identity"]) 214 | , import_ "Lucid" Nothing 215 | , import_ "Network.Wai" (Just ["Application"]) 216 | , import_ "Network.Wai.Handler.Warp" (Just ["run"]) 217 | , import_ "Network.Wai.Middleware.RequestLogger" (Just ["logStdoutDev"]) 218 | , import_ "Trasa.Core" Nothing 219 | , import_ "Trasa.Server" (Just ["TrasaT", "serveWith"]) 220 | , "" 221 | , import_ "Common" Nothing 222 | , "" 223 | , "type App = TrasaT IO" 224 | , "" 225 | , "main :: IO ()" 226 | , "main = run 8080 (logStdoutDev application)" 227 | , "" 228 | , "application :: Application" 229 | , "application = serveWith" 230 | , " (metaCodecToMetaServer . meta)" 231 | , " routes" 232 | , " router" 233 | , "" 234 | , "routes :: forall captures queries request response. ()" 235 | , " => Route captures queries request response" 236 | , " -> Rec Identity captures" 237 | , " -> Rec Parameter queries" 238 | , " -> RequestBody Identity request" 239 | , " -> App response" 240 | , "routes route captures queries reqBody = case route of" 241 | , " HelloWorld -> go helloWorld" 242 | , " where" 243 | , " go :: Arguments captures queries request (App response) -> App response" 244 | , " go f = handler captures queries reqBody f" 245 | , "" 246 | , "router :: Router Route" 247 | , "router = routerWith" 248 | , " (mapMeta captureDecoding captureDecoding id id . meta)" 249 | , " allRoutes" 250 | , "" 251 | , "helloWorld :: App (Html ())" 252 | , "helloWorld = pure $ h1_ \"Hello, World!\"" 253 | ] 254 | 255 | cabalFile :: () 256 | => String 257 | -- ^ library name 258 | -> String 259 | cabalFile name = unlines 260 | [ "cabal-version: 2.2" 261 | , "name:" 262 | , " " <> name 263 | , "version:" 264 | , " 0.1" 265 | , "build-type:" 266 | , " Simple" 267 | , "" 268 | , "library" 269 | , " hs-source-dirs:" 270 | , " src" 271 | , " exposed-modules:" 272 | , " Client" 273 | , " Common" 274 | , " Server" 275 | , " build-depends:" 276 | , " , aeson" 277 | , " , base >= 4.11 && < 4.15" 278 | , " , bytestring" 279 | , " , http-client" 280 | , " , lucid" 281 | , " , quantification" 282 | , " , text" 283 | , " , trasa" 284 | , " , trasa-client" 285 | , " , trasa-server" 286 | , " , wai" 287 | , " , wai-extra" 288 | , " , warp" 289 | , " ghc-options:" 290 | , " -Wall -O2" 291 | , " default-language:" 292 | , " Haskell2010" 293 | , "" 294 | , "executable " <> name 295 | , " hs-source-dirs:" 296 | , " app" 297 | , " main-is:" 298 | , " Main.hs" 299 | , " build-depends:" 300 | , " , base" 301 | , " , " <> name 302 | , " ghc-options:" 303 | , " -Wall -O2" 304 | , " default-language:" 305 | , " Haskell2010" 306 | ] 307 | 308 | defaultNix :: String -> TreeFs 309 | defaultNix name = File "default.nix" $ unlines 310 | [ "{ system ? builtins.currentSystem" 311 | , ", compiler ? \"ghc865\"" 312 | , ", ..." 313 | , "}:" 314 | , "" 315 | , "with rec {" 316 | , " pkgs = import ./.nix/pinned-nixpkgs.nix {" 317 | , " inherit system;" 318 | , " config = {" 319 | , " allowUnfree = true;" 320 | , " packageOverrides = pkgs: rec {" 321 | , " haskellPackages = pkgs.haskell.packages.\"${compiler}\".override {" 322 | , " overrides = hself: hsuper:" 323 | , " with pkgs.haskell.lib; rec {" 324 | , " trasa = hself.callPackage ./.nix/trasa.nix {};" 325 | , " trasa-client = hself.callPackage ./.nix/trasa-client.nix {};" 326 | , " trasa-server = hself.callPackage ./.nix/trasa-server.nix {};" 327 | , " };" 328 | , " };" 329 | , " };" 330 | , " };" 331 | , " };" 332 | , "" 333 | , " src = pkgs.lib.cleanSource ./.;" 334 | , "};" 335 | , "" 336 | , "rec {" 337 | , " " <> name <> " =" 338 | , " with pkgs.haskell.lib;" 339 | , " with pkgs.haskellPackages;" 340 | , " overrideCabal (" 341 | , " justStaticExecutables (" 342 | , " callCabal2nix \"" <> name <> "\" src {}" 343 | , " )" 344 | , " ) (old: {" 345 | , " });" 346 | , "}" 347 | ] 348 | 349 | shellNix :: String -> TreeFs 350 | shellNix name = File "shell.nix" $ unlines 351 | [ "(import ./default.nix {})." <> name <> ".env" 352 | ] 353 | -------------------------------------------------------------------------------- /trasa-init/changelog.md: -------------------------------------------------------------------------------- 1 | # Revision history for fun 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /trasa-init/readme.md: -------------------------------------------------------------------------------- 1 | # trasa-init 2 | -------------------------------------------------------------------------------- /trasa-init/res/nixpkgs.json: -------------------------------------------------------------------------------- 1 | { 2 | "url": "https://github.com/nixos/nixpkgs-channels", 3 | "rev": "f3fa5a101eb74a10f6c53b504e18b42bacccbaeb", 4 | "date": "2019-12-03T16:52:39+00:00", 5 | "sha256": "0mf8n78xhni57f5pgc5rc7l3sgnar95998gi06a1anf8gqnrrhn1", 6 | "fetchSubmodules": false 7 | } 8 | -------------------------------------------------------------------------------- /trasa-init/res/pinned-nixpkgs.nix: -------------------------------------------------------------------------------- 1 | { system ? builtins.currentSystem, config ? {} }: 2 | let 3 | json = builtins.fromJSON (builtins.readFile ./nixpkgs.json); 4 | src = builtins.fetchTarball { 5 | url = "https://github.com/nixos/nixpkgs-channels/archive/${json.rev}.tar.gz"; 6 | inherit (json) sha256; 7 | }; 8 | in 9 | import src { inherit system config; } 10 | -------------------------------------------------------------------------------- /trasa-init/res/trasa-client.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, binary, bytestring, case-insensitive 2 | , containers, fetchgit, http-client, http-media, http-types, stdenv 3 | , text, trasa 4 | }: 5 | mkDerivation { 6 | pname = "trasa-client"; 7 | version = "0.4"; 8 | src = fetchgit { 9 | url = "https://github.com/haskell-trasa/trasa"; 10 | sha256 = "175dw10hxygzpx5vic7ssg9vbl7adpfrq9rwsr739h20d60ywf4a"; 11 | rev = "d82f2a997b369cf08933d65642367c5a2ffe4c85"; 12 | fetchSubmodules = true; 13 | }; 14 | postUnpack = "sourceRoot+=/trasa-client; echo source root reset to $sourceRoot"; 15 | libraryHaskellDepends = [ 16 | base binary bytestring case-insensitive containers http-client 17 | http-media http-types text trasa 18 | ]; 19 | homepage = "https://github.com/haskell-trasa/trasa"; 20 | description = "Type safe http requests"; 21 | license = stdenv.lib.licenses.mit; 22 | } 23 | -------------------------------------------------------------------------------- /trasa-init/res/trasa-server.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bytestring, case-insensitive, containers 2 | , fetchgit, http-media, http-types, mtl, stdenv, text, trasa, wai 3 | }: 4 | mkDerivation { 5 | pname = "trasa-server"; 6 | version = "0.5.4"; 7 | src = fetchgit { 8 | url = "https://github.com/haskell-trasa/trasa"; 9 | sha256 = "099vqqhhmrnj9r29an31j5y9s0hrzi16wv0syh5xdbf2phh4pggj"; 10 | rev = "0e80962de3c03eeff20c85261500217ecc2b8f93"; 11 | fetchSubmodules = true; 12 | }; 13 | postUnpack = "sourceRoot+=/trasa-server; echo source root reset to $sourceRoot"; 14 | libraryHaskellDepends = [ 15 | base bytestring case-insensitive containers http-media http-types 16 | mtl text trasa wai 17 | ]; 18 | homepage = "https://github.com/haskell-trasa/trasa"; 19 | description = "Type safe web server"; 20 | license = stdenv.lib.licenses.mit; 21 | } 22 | -------------------------------------------------------------------------------- /trasa-init/res/trasa.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, binary, bytestring, doctest, fetchgit 2 | , hashable, http-media, http-types, quantification, stdenv 3 | , template-haskell, text, th-abstraction, unordered-containers 4 | }: 5 | mkDerivation { 6 | pname = "trasa"; 7 | version = "0.4.1"; 8 | src = fetchgit { 9 | url = "https://github.com/haskell-trasa/trasa"; 10 | sha256 = "099vqqhhmrnj9r29an31j5y9s0hrzi16wv0syh5xdbf2phh4pggj"; 11 | rev = "0e80962de3c03eeff20c85261500217ecc2b8f93"; 12 | fetchSubmodules = true; 13 | }; 14 | postUnpack = "sourceRoot+=/trasa; echo source root reset to $sourceRoot"; 15 | libraryHaskellDepends = [ 16 | base binary bytestring hashable http-media http-types 17 | quantification template-haskell text th-abstraction 18 | unordered-containers 19 | ]; 20 | testHaskellDepends = [ base doctest ]; 21 | homepage = "https://github.com/haskell-trasa/trasa"; 22 | description = "Type Safe Web Routing"; 23 | license = stdenv.lib.licenses.mit; 24 | } 25 | -------------------------------------------------------------------------------- /trasa-init/trasa-init.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: 3 | trasa-init 4 | version: 5 | 0.1 6 | -- synopsis: 7 | -- description: 8 | bug-reports: 9 | https://github.com/chessai/trasa-init.git 10 | license: 11 | MIT 12 | license-file: 13 | LICENSE 14 | author: 15 | chessai 16 | maintainer: 17 | chessai 18 | build-type: 19 | Simple 20 | extra-source-files: 21 | changelog.md 22 | readme.md 23 | 24 | executable trasa-init 25 | hs-source-dirs: 26 | app 27 | main-is: 28 | Main.hs 29 | build-depends: 30 | , base >= 4.11 && < 4.15 31 | , directory 32 | , file-embed 33 | ghc-options: 34 | -Wall -Werror -O2 35 | default-language: 36 | Haskell2010 37 | -------------------------------------------------------------------------------- /trasa-reflex/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for trasa-reflex 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /trasa-reflex/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017-2019 Andrew Martin 2 | Copyright 2017-2019 Kyle McKean 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 5 | 6 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 9 | -------------------------------------------------------------------------------- /trasa-reflex/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /trasa-reflex/cachix.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | nix-build -j1 -Q && nix-store -qR result | cachix push layer-3-cachix 6 | -------------------------------------------------------------------------------- /trasa-reflex/src/Reflex/PopState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | module Reflex.PopState (url) where 5 | 6 | import Data.Monoid ((<>)) 7 | import GHCJS.DOM (currentWindowUnchecked) 8 | import GHCJS.DOM.EventM (on) 9 | import GHCJS.DOM.Location (getPathname,getSearch) 10 | import GHCJS.DOM.Types (MonadJSM,liftJSM,ToJSVal(..)) 11 | import GHCJS.DOM.Window (getLocation) 12 | import GHCJS.DOM.WindowEventHandlers (popState) 13 | import Language.Javascript.JSaddle (eval,call) 14 | import Reflex.Class (Reflex(..),MonadHold(..),ffor) 15 | import Reflex.Dom.Builder.Immediate (wrapDomEvent) 16 | import Reflex.PerformEvent.Class (PerformEvent(..)) 17 | import Reflex.TriggerEvent.Class (TriggerEvent) 18 | import Trasa.Core (Url,decodeUrl,encodeUrl) 19 | import qualified Data.Text as T 20 | 21 | getPopState :: (Reflex t, TriggerEvent t m, MonadJSM m) => m (Event t Url) 22 | getPopState = do 23 | window <- currentWindowUnchecked 24 | wrapDomEvent window (`on` popState) $ do 25 | loc <- getLocation window 26 | locStr <- getPathname loc 27 | searchStr <- getSearch loc 28 | return (decodeUrl (locStr <> searchStr)) 29 | 30 | -- | The starting location and a stream of popstate urls 31 | url :: (MonadHold t m, TriggerEvent t m, PerformEvent t m, MonadJSM (Performable m), MonadJSM m) => 32 | Event t Url -> m (Url, Event t Url) 33 | url us = do 34 | u0 <- liftJSM $ do 35 | window <- currentWindowUnchecked 36 | loc <- getLocation window 37 | locStr <- getPathname loc 38 | searchStr <- getSearch loc 39 | return (decodeUrl (locStr <> searchStr)) 40 | performEvent_ $ ffor us $ \uri -> liftJSM $ do 41 | f <- eval ("(function (url) { window[\"history\"][\"pushState\"](0,\"\",url) })" :: T.Text) 42 | jsUri <- toJSVal (encodeUrl uri) 43 | _ <- call f f [jsUri] 44 | return () 45 | ps <- getPopState 46 | return (u0, ps) 47 | -------------------------------------------------------------------------------- /trasa-reflex/src/Trasa/Reflex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveTraversable #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE RecursiveDo #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | {-# OPTIONS_GHC -Wall -Werror #-} 14 | module Trasa.Reflex 15 | ( MetaReflex 16 | , metaCodecToMetaReflex 17 | , metaReflexToMetaClient 18 | , requestWith 19 | , requestManyWith 20 | , ResponseHandler(..) 21 | , requestMultiWith 22 | , serveWith 23 | , Arguments 24 | , EventArguments 25 | , handler 26 | , eventHandler 27 | , dynamicHandler 28 | , Requiem(..) 29 | , serveEventfulWith 30 | , serveDynamicWith 31 | , serveDynamicIntermWith 32 | , ResponseError(..) 33 | , DecodeError(..) 34 | ) where 35 | 36 | import Data.Kind (Type) 37 | 38 | import qualified Data.Text.Encoding as TE 39 | import qualified Data.ByteString as BS 40 | import qualified Data.ByteString.Lazy as LBS (toStrict,fromStrict) 41 | 42 | import Data.Bifunctor (first) 43 | import Data.Monoid ((<>)) 44 | import Data.Type.Equality ((:~:)(Refl)) 45 | import Data.Functor.Identity (Identity(..)) 46 | import Data.Foldable (toList) 47 | import qualified Data.Map.Strict as M 48 | import qualified Network.HTTP.Media as N 49 | import Reflex.Dom 50 | import Control.Monad (forM,when) 51 | import Data.Text (Text) 52 | import Data.Map.Strict (Map) 53 | import Control.Applicative ((<|>)) 54 | import Data.Proxy (Proxy(..)) 55 | import qualified Topaz.Rec as Topaz 56 | 57 | import Trasa.Core hiding (requestWith,Arguments,handler) 58 | 59 | import Reflex.PopState 60 | 61 | data DecodeError 62 | = BadStatusCode !Word 63 | | MissingContentType -- Content-Type header was missing 64 | | UnparseableContentType !Text 65 | | MissingBody -- No response body 66 | | UnsupportedMediaType !N.MediaType -- Received a bad content-type from the server 67 | | UnparseableContent !Text -- The response body could not be parsed, field is error returned by parser 68 | deriving (Show) 69 | 70 | data ResponseError route = ResponseError !XhrResponse !(Concealed route) !DecodeError 71 | 72 | -- | Replaces 'Trasa.Core.Arguments' with one that does not deal with request bodies 73 | type family Arguments (caps :: [Type]) (qrys :: [Param]) (resp :: Type) (result :: Type) :: Type where 74 | Arguments '[] '[] resp result = resp -> result 75 | Arguments '[] (q:qs) resp result = ParamBase q -> Arguments '[] qs resp result 76 | Arguments (cap:caps) qs resp result = cap -> Arguments caps qs resp result 77 | 78 | -- | Replaces 'Trasa.Core.Arguments' with one that does not deal with request bodies. 79 | -- Everything is wrapped in an 'Event'. 80 | type family EventArguments (t :: Type) (caps :: [Type]) (qrys :: [Param]) (resp :: Type) (result :: Type) :: Type where 81 | EventArguments t '[] '[] resp result = Event t resp -> result 82 | EventArguments t '[] (q:qs) resp result = Event t (ParamBase q) -> EventArguments t '[] qs resp result 83 | EventArguments t (cap:caps) qs resp result = Event t cap -> EventArguments t caps qs resp result 84 | 85 | -- | Replaces 'Trasa.Core.Arguments' with one that does not deal with request bodies. 86 | -- Everything is wrapped in a 'Dynamic'. 87 | type family DynamicArguments (t :: Type) (caps :: [Type]) (qrys :: [Param]) (resp :: Type) (result :: Type) :: Type where 88 | DynamicArguments t '[] '[] resp result = Dynamic t resp -> result 89 | DynamicArguments t '[] (q:qs) resp result = Dynamic t (ParamBase q) -> DynamicArguments t '[] qs resp result 90 | DynamicArguments t (cap:caps) qs resp result = Dynamic t cap -> DynamicArguments t caps qs resp result 91 | 92 | -- | Trasa.Reflex.'Trasa.Reflex.handler' is to Trasa.Core.'Trasa.Core.handler' as Trasa.Reflex.'Trasa.Reflex.Arguments' is to Trasa.Core.'Trasa.Core.Arguments' 93 | handler :: Rec Identity caps -> Rec Parameter qrys -> ResponseBody Identity resp -> Arguments caps qrys resp x -> x 94 | handler = go 95 | where 96 | go :: Rec Identity caps -> Rec Parameter qrys -> ResponseBody Identity resp -> Arguments caps qrys resp x -> x 97 | go RecNil RecNil (ResponseBody (Identity response)) f = f response 98 | go RecNil (q `RecCons` qs) respBody f = go RecNil qs respBody (f (demoteParameter q)) 99 | go (Identity cap `RecCons` caps) qs respBody f = go caps qs respBody (f cap) 100 | 101 | 102 | 103 | eventHandler :: forall t caps qrys resp x. Reflex t 104 | => Rec Proxy caps 105 | -> Rec Proxy qrys 106 | -> Event t (Requiem caps qrys resp) 107 | -> EventArguments t caps qrys resp x 108 | -> x 109 | eventHandler caps qrys e = go (selfSubset caps) (selfSubset qrys) 110 | where 111 | go :: forall caps' qrys'. Rec (Elem caps) caps' -> Rec (Elem qrys) qrys' -> EventArguments t caps' qrys' resp x -> x 112 | go RecNil RecNil f = f (fmap (\(Requiem _ _ theResp) -> theResp) e) 113 | go RecNil (qryElem `RecCons` qs) f = go RecNil qs (f (fmap (\(Requiem _ qryVals _) -> case elemGet qryElem qryVals of 114 | ParameterFlag v -> v 115 | ParameterRequired v -> v 116 | ParameterOptional v -> v 117 | ParameterList v -> v 118 | ) e)) 119 | go (capElem `RecCons` cs) qryElems f = go cs qryElems (f (fmap (\(Requiem capVals _ _) -> runIdentity (elemGet capElem capVals)) e)) 120 | 121 | dynamicHandler :: forall t caps qrys resp x. Reflex t 122 | => Rec Proxy caps 123 | -> Rec Proxy qrys 124 | -> Dynamic t (Requiem caps qrys resp) 125 | -> DynamicArguments t caps qrys resp x 126 | -> x 127 | dynamicHandler caps qrys e = go (selfSubset caps) (selfSubset qrys) 128 | where 129 | go :: forall caps' qrys'. Rec (Elem caps) caps' -> Rec (Elem qrys) qrys' -> DynamicArguments t caps' qrys' resp x -> x 130 | go RecNil RecNil f = f (fmap (\(Requiem _ _ theResp) -> theResp) e) 131 | go RecNil (qryElem `RecCons` qs) f = go RecNil qs (f (fmap (\(Requiem _ qryVals _) -> case elemGet qryElem qryVals of 132 | ParameterFlag v -> v 133 | ParameterRequired v -> v 134 | ParameterOptional v -> v 135 | ParameterList v -> v 136 | ) e)) 137 | go (capElem `RecCons` cs) qryElems f = go cs qryElems (f (fmap (\(Requiem capVals _ _) -> runIdentity (elemGet capElem capVals)) e)) 138 | 139 | data Elem (as :: [k]) (a :: k) where 140 | ElemHere :: Elem (a ': as) a 141 | ElemThere :: Elem as a -> Elem (b ': as) a 142 | 143 | elemGet :: Elem rs r -> Rec f rs -> f r 144 | elemGet ElemHere (r `RecCons` _) = r 145 | elemGet (ElemThere elemNext) (_ `RecCons` rs) = elemGet elemNext rs 146 | 147 | selfSubset :: Rec Proxy rs -> Rec (Elem rs) rs 148 | selfSubset RecNil = RecNil 149 | selfSubset (Proxy `RecCons` rs) = ElemHere `RecCons` Topaz.map ElemThere (selfSubset rs) 150 | 151 | -- | Used when you want to perform an action for any response type 152 | data ResponseHandler route a = forall resp. ResponseHandler 153 | !(Prepared route resp) 154 | !(ResponseBody (Many BodyDecoding) resp) 155 | !(resp -> a) 156 | 157 | data Pair a b = Pair !a !b 158 | deriving (Functor, Foldable, Traversable) 159 | 160 | newtype Preps route resp f a = Preps (f (Pair (ResponseHandler route resp) a)) 161 | deriving (Functor,Foldable,Traversable) 162 | 163 | type MetaReflex = Meta CaptureEncoding CaptureCodec (Many BodyCodec) (Many BodyDecoding) 164 | 165 | metaCodecToMetaReflex :: MetaCodec caps qrys req resp -> MetaReflex caps qrys req resp 166 | metaCodecToMetaReflex = mapMeta captureEncoding id id (mapMany bodyDecoding) 167 | 168 | metaReflexToMetaClient :: MetaReflex caps qrys req resp -> MetaClient caps qrys req resp 169 | metaReflexToMetaClient = mapMeta id captureEncoding (mapMany bodyEncoding) id 170 | 171 | -- | Single request version of 'requestManyWith' 172 | requestWith 173 | :: forall t m route response 174 | . MonadWidget t m 175 | => (forall caps qrys req resp. route caps qrys req resp -> MetaClient caps qrys req resp) 176 | -> Event t (Prepared route response) 177 | -> m (Event t (Either (ResponseError route) response)) 178 | requestWith toMeta prepared = 179 | coerceEvent <$> requestManyWith toMeta preparedId 180 | where preparedId = coerceEvent prepared :: Event t (Identity (Prepared route response)) 181 | 182 | -- | Perform n requests and collect the results 183 | requestManyWith 184 | :: forall t m f route response 185 | . (MonadWidget t m, Traversable f) 186 | => (forall caps qrys req resp. route caps qrys req resp -> MetaClient caps qrys req resp) 187 | -> Event t (f (Prepared route response)) 188 | -- ^ The routes to request 189 | -> m (Event t (f (Either (ResponseError route) response))) 190 | requestManyWith toMeta prepared = 191 | requestMultiWith toMeta (fmap toResponseHandler <$> prepared) 192 | where toResponseHandler p@(Prepared route _ _ _) = ResponseHandler p (metaResponseBody (toMeta route)) id 193 | 194 | decodeResponseBody' :: ResponseBody (Many BodyDecoding) response -> Content -> Either DecodeError response 195 | decodeResponseBody' (ResponseBody (Many decodings)) (Content name content) = go (toList decodings) 196 | where 197 | go :: [BodyDecoding response] -> Either DecodeError response 198 | go [] = Left (UnsupportedMediaType name) 199 | go (BodyDecoding names dec:decs) = case any (N.matches name) names of 200 | True -> first UnparseableContent (dec content) 201 | False -> go decs 202 | 203 | -- | Internal function but exported because it subsumes the function of all the other functions in this package. 204 | -- Very powerful function 205 | requestMultiWith :: forall t m f route a. 206 | (MonadWidget t m, Traversable f) 207 | => (forall caps qrys req resp. route caps qrys req resp -> MetaClient caps qrys req resp) 208 | -> Event t (f (ResponseHandler route a)) 209 | -> m (Event t (f (Either (ResponseError route) a))) 210 | requestMultiWith toMeta contResp = 211 | fmap parseXhrResponses <$> performRequestsAsync (buildXhrRequests <$> contResp) 212 | where parseXhrResponses :: Preps route a f XhrResponse -> f (Either (ResponseError route) a) 213 | parseXhrResponses (Preps res) = fmap parseOneXhrResponse res 214 | parseOneXhrResponse :: Pair (ResponseHandler route a) XhrResponse -> Either (ResponseError route) a 215 | parseOneXhrResponse (Pair (ResponseHandler theRoute responseBody fromResp) xhrResp@(XhrResponse statusCode _ _ response headers)) = first (ResponseError xhrResp (conceal theRoute)) $ do 216 | when (statusCode >= 400) (Left (BadStatusCode statusCode)) 217 | theContentType <- maybe (Left MissingContentType) Right (M.lookup "Content-Type" headers <|> M.lookup "content-type" headers) 218 | content <- maybe (Left (UnparseableContentType theContentType)) Right (N.parseAccept (TE.encodeUtf8 theContentType)) 219 | txt <- maybe (Left MissingBody) Right response 220 | let bs = LBS.fromStrict (TE.encodeUtf8 txt) 221 | fmap fromResp (decodeResponseBody' responseBody (Content content bs)) 222 | buildXhrRequests :: f (ResponseHandler route a) -> Preps route a f (XhrRequest BS.ByteString) 223 | buildXhrRequests = Preps . fmap buildOneXhrRequest 224 | buildOneXhrRequest :: ResponseHandler route a -> Pair (ResponseHandler route a) (XhrRequest BS.ByteString) 225 | buildOneXhrRequest w@(ResponseHandler p@(Prepared route _ _ _) _ _) = 226 | Pair w (XhrRequest method (encodeUrl (linkWith toMeta p)) conf) 227 | where 228 | method = (encodeMethod . metaMethod . toMeta) route 229 | conf :: XhrRequestConfig BS.ByteString 230 | conf = def 231 | & xhrRequestConfig_sendData .~ maybe "" (LBS.toStrict . contentData) content 232 | & xhrRequestConfig_headers .~ headers 233 | & xhrRequestConfig_responseHeaders .~ AllHeaders 234 | -- headers = maybe acceptHeader (\ct -> M.insert "Content-Type" (contentType ct) acceptHeader) content 235 | headers = case content of 236 | Nothing -> acceptHeader 237 | Just (Content typ _) -> M.insert "Content-Type" (TE.decodeUtf8 (N.renderHeader typ)) acceptHeader 238 | acceptHeader = "Accept" =: (TE.decodeUtf8 . BS.intercalate ", " . fmap N.renderHeader . toList) accepts 239 | Payload _ content accepts = payloadWith toMeta p 240 | 241 | -- | Used to serve single page apps 242 | serveWith 243 | :: forall t m route 244 | . MonadWidget t m 245 | => (forall caps qrys req resp. route caps qrys req resp -> MetaReflex caps qrys req resp) 246 | -> Router route 247 | -> (forall caps qrys req resp. 248 | route caps qrys req resp -> 249 | Rec Identity caps -> 250 | Rec Parameter qrys -> 251 | ResponseBody Identity resp -> 252 | m (Event t (Concealed route))) 253 | -- ^ Build a widget from captures, query parameters, and a response body 254 | -> (ResponseError route -> m (Event t (Concealed route))) 255 | -> m () 256 | serveWith toMeta madeRouter widgetize onErr = mdo 257 | -- Investigate why this is needed 258 | let newUrls :: Event t Url 259 | newUrls = ffor (switch (current jumpsD)) $ \(Concealed route caps querys reqBody) -> 260 | linkWith (mapMetaQuery captureEncoding . toMeta) (Prepared route caps querys reqBody) 261 | (u0, urls) <- url newUrls 262 | pb <- getPostBuild 263 | let transMetaParse = mapMetaQuery captureDecoding . mapMetaRequestBody (mapMany bodyDecoding) 264 | choice :: Event t (Either TrasaErr (Concealed route)) 265 | choice = ffor (leftmost [newUrls, urls, u0 <$ pb]) $ \us -> 266 | parseWith (transMetaParse . toMeta) madeRouter "GET" us Nothing 267 | (_failures, concealeds) = fanEither choice 268 | actions <- requestMultiWith (metaReflexToMetaClient . toMeta) (fromConcealed <$> concealeds) 269 | jumpsD <- widgetHold (return never) (leftmost [either onErr id . runIdentity <$> actions]) 270 | return () 271 | where 272 | fromConcealed :: Concealed route -> Identity (ResponseHandler route (m (Event t (Concealed route)))) 273 | fromConcealed (Concealed route caps querys reqBody) = 274 | Identity (ResponseHandler (Prepared route caps querys reqBody) (metaResponseBody (toMeta route)) 275 | (widgetize route caps querys . ResponseBody . Identity)) 276 | 277 | data Requiem caps qrys resp = Requiem 278 | { requiemCaptures :: Rec Identity caps 279 | , requiemQueries :: Rec Parameter qrys 280 | , requiemResponse :: resp 281 | } 282 | 283 | serveEventfulWith :: forall t m (route :: [Type] -> [Param] -> Bodiedness -> Type -> Type). MonadWidget t m 284 | => (forall caps1 qrys1 req1 resp1 caps2 qrys2 req2 resp2. route caps1 qrys1 req1 resp1 -> route caps2 qrys2 req2 resp2 -> Maybe ('(caps1,qrys1,req1,resp1) :~: '(caps2,qrys2,req2,resp2))) 285 | -> (forall caps qrys req resp. route caps qrys req resp -> MetaReflex caps qrys req resp) 286 | -> Router route 287 | -> (forall caps qrys req resp. 288 | route caps qrys req resp 289 | -> Event t (Requiem caps qrys resp) 290 | -> (Map Text Text, m (Event t (Concealed route))) -- first item is css class 291 | ) 292 | -- ^ Build a widget from captures, query parameters, and a response body 293 | -> (Event t (ResponseError route) -> (Map Text Text, m (Event t (Concealed route)))) -- first item is css class 294 | -> [Constructed route] 295 | -> Event t (Concealed route) -- ^ extra jumps, possibly from menu bar 296 | -> Event t () -- ^ event that only fires once, build everything once this fires, often getPostBuild 297 | -> m (Event t (Concealed route)) 298 | serveEventfulWith testRouteEquality toMeta madeRouter widgetize onErr routes extraJumps fire = mdo 299 | -- Investigate why this is needed 300 | let newUrls :: Event t Url 301 | newUrls = ffor (leftmost [jumpsE,errJumpsE,extraJumps]) $ \(Concealed route caps querys reqBody) -> 302 | linkWith (mapMetaQuery captureEncoding . toMeta) (Prepared route caps querys reqBody) 303 | (u0, urls) <- url newUrls 304 | let transMetaParse = mapMetaQuery captureDecoding . mapMetaRequestBody (mapMany bodyDecoding) 305 | choice :: Event t (Either TrasaErr (Concealed route)) 306 | choice = ffor (leftmost [newUrls, urls, u0 <$ fire]) $ \us -> 307 | parseWith (transMetaParse . toMeta) madeRouter "GET" us Nothing 308 | -- currently ignoring parse failures 309 | (_parseFailures, concealeds) = fanEither choice 310 | actions' :: Event t (Identity (Either (ResponseError route) (FullMonty route))) <- requestMultiWith (metaReflexToMetaClient . toMeta) (fromConcealed <$> concealeds) 311 | let actions = (coerceEvent actions' :: Event t (Either (ResponseError route) (FullMonty route))) 312 | let hidden = M.singleton "style" "display:none;" 313 | jumpsE <- fmap leftmost $ forM routes $ \(Constructed route) -> do 314 | let m = fmap (either (const Nothing) (castRequiem route)) actions 315 | attrs <- holdDyn hidden (fmap (maybe hidden (const M.empty)) m) 316 | let (rtStaticAttrs,rtWidg) = widgetize route (fmapMaybe id m) 317 | elDynAttr "div" (fmap (M.unionWith (<>) rtStaticAttrs) attrs) $ do 318 | rtWidg 319 | let merr = fmap (either Just (const Nothing)) actions 320 | errAttrs <- holdDyn hidden (fmap (maybe hidden (const M.empty)) merr) 321 | let (errStaticAttrs,errWidg) = onErr (fmapMaybe id merr) 322 | errJumpsE <- elDynAttr "div" (fmap (M.unionWith (<>) errStaticAttrs) errAttrs) $ do 323 | errWidg 324 | return concealeds 325 | where 326 | castRequiem :: route w x y z -> FullMonty route -> Maybe (Requiem w x z) 327 | castRequiem route (FullMonty incomingRoute caps querys theResp) = case testRouteEquality route incomingRoute of 328 | Nothing -> Nothing 329 | Just Refl -> Just (Requiem caps querys theResp) 330 | fromConcealed :: Concealed route -> Identity (ResponseHandler route (FullMonty route)) 331 | fromConcealed (Concealed route caps querys reqBody) = Identity 332 | ( ResponseHandler 333 | (Prepared route caps querys reqBody) 334 | (metaResponseBody (toMeta route)) 335 | (FullMonty route caps querys) 336 | ) 337 | 338 | dynAfter :: forall t m a b. MonadWidget t m => Event t a -> (Dynamic t a -> m (Event t b)) -> m (Event t b) 339 | dynAfter e f = do 340 | e1 <- headE e 341 | let em1 = fmap (\a1 -> holdDyn a1 e >>= f) e1 342 | de <- widgetHold (return never) em1 343 | return (switch (current de)) 344 | 345 | serveDynamicWith :: forall t m (route :: [Type] -> [Param] -> Bodiedness -> Type -> Type). MonadWidget t m 346 | => (forall caps1 qrys1 req1 resp1 caps2 qrys2 req2 resp2. route caps1 qrys1 req1 resp1 -> route caps2 qrys2 req2 resp2 -> Maybe ('(caps1,qrys1,req1,resp1) :~: '(caps2,qrys2,req2,resp2))) 347 | -> (forall caps qrys req resp. route caps qrys req resp -> MetaReflex caps qrys req resp) 348 | -> Router route 349 | -> (forall caps qrys req resp. route caps qrys req resp -> Map Text Text) 350 | -- ^ Turn route into static html attributes 351 | -> (forall caps qrys req resp. 352 | route caps qrys req resp 353 | -> Dynamic t (Requiem caps qrys resp) 354 | -> m (Event t (Concealed route)) 355 | ) 356 | -- ^ Build a widget from captures, query parameters, and a response body 357 | -> (Event t (ResponseError route) -> (Map Text Text, m (Event t (Concealed route)))) -- first item is css class 358 | -> [Constructed route] 359 | -> Event t (Concealed route) -- ^ extra jumps, possibly from menu bar 360 | -> Event t () -- ^ event that only fires once, build everything once this fires, often getPostBuild 361 | -> m (Event t (Concealed route)) 362 | serveDynamicWith testRouteEquality toMeta madeRouter attrize widgetize onErr routes extraJumps fire = mdo 363 | -- Investigate why this is needed 364 | let newUrls :: Event t Url 365 | newUrls = ffor (leftmost [jumpsE,errJumpsE,extraJumps]) $ \(Concealed route caps querys reqBody) -> 366 | linkWith (mapMetaQuery captureEncoding . toMeta) (Prepared route caps querys reqBody) 367 | (u0, urls) <- url newUrls 368 | let transMetaParse = mapMetaQuery captureDecoding . mapMetaRequestBody (mapMany bodyDecoding) 369 | choice :: Event t (Either TrasaErr (Concealed route)) 370 | choice = ffor (leftmost [newUrls, urls, u0 <$ fire]) $ \us -> 371 | parseWith (transMetaParse . toMeta) madeRouter "GET" us Nothing 372 | -- currently ignoring parse failures 373 | (_parseFailures, concealeds) = fanEither choice 374 | actions' :: Event t (Identity (Either (ResponseError route) (FullMonty route))) <- requestMultiWith (metaReflexToMetaClient . toMeta) (fromConcealed <$> concealeds) 375 | let actions = (coerceEvent actions' :: Event t (Either (ResponseError route) (FullMonty route))) 376 | let hidden = M.singleton "style" "display:none;" 377 | jumpsE <- fmap leftmost $ forM routes $ \(Constructed route) -> do 378 | let m = fmap (either (const Nothing) (castRequiem route)) actions 379 | attrs <- holdDyn hidden (fmap (maybe hidden (const M.empty)) m) 380 | let rtStaticAttrs = attrize route 381 | let rtWidg = dynAfter (fmapMaybe id m) (widgetize route) 382 | elDynAttr "div" (fmap (M.unionWith (<>) rtStaticAttrs) attrs) $ do 383 | rtWidg 384 | let merr = fmap (either Just (const Nothing)) actions 385 | errAttrs <- holdDyn hidden (fmap (maybe hidden (const M.empty)) merr) 386 | let (errStaticAttrs,errWidg) = onErr (fmapMaybe id merr) 387 | errJumpsE <- elDynAttr "div" (fmap (M.unionWith (<>) errStaticAttrs) errAttrs) $ do 388 | errWidg 389 | return concealeds 390 | where 391 | castRequiem :: route w x y z -> FullMonty route -> Maybe (Requiem w x z) 392 | castRequiem route (FullMonty incomingRoute caps querys theResp) = case testRouteEquality route incomingRoute of 393 | Nothing -> Nothing 394 | Just Refl -> Just (Requiem caps querys theResp) 395 | fromConcealed :: Concealed route -> Identity (ResponseHandler route (FullMonty route)) 396 | fromConcealed (Concealed route caps querys reqBody) = Identity 397 | ( ResponseHandler 398 | (Prepared route caps querys reqBody) 399 | (metaResponseBody (toMeta route)) 400 | (FullMonty route caps querys) 401 | ) 402 | 403 | serveDynamicIntermWith :: forall t m (route :: [Type] -> [Param] -> Bodiedness -> Type -> Type). MonadWidget t m 404 | => (forall caps1 qrys1 req1 resp1 caps2 qrys2 req2 resp2. route caps1 qrys1 req1 resp1 -> route caps2 qrys2 req2 resp2 -> Maybe ('(caps1,qrys1,req1,resp1) :~: '(caps2,qrys2,req2,resp2))) 405 | -> (forall caps qrys req resp. route caps qrys req resp -> MetaReflex caps qrys req resp) 406 | -> Router route 407 | -> (forall caps qrys req resp. route caps qrys req resp -> Map Text Text) 408 | -- ^ Turn route into static html attributes 409 | -> (forall caps qrys req resp. 410 | route caps qrys req resp 411 | -> Dynamic t (Requiem caps qrys resp) 412 | -> m (Event t (Concealed route)) 413 | ) 414 | -- ^ Build a widget from captures, query parameters, and a response body 415 | -> (Event t (ResponseError route) -> (Map Text Text, m (Event t (Concealed route)))) -- first item is css class 416 | -> m (Event t (Concealed route)) 417 | -> [Constructed route] 418 | -> Event t (Concealed route) -- ^ extra jumps, possibly from menu bar 419 | -> Event t () -- ^ event that only fires once, build everything once this fires, often getPostBuild 420 | -> m (Event t (Concealed route)) 421 | serveDynamicIntermWith testRouteEquality toMeta madeRouter attrize widgetize onErr interm routes extraJumps fire = mdo 422 | -- Investigate why this is needed 423 | let newUrls :: Event t Url 424 | newUrls = ffor (leftmost [jumpsE,errJumpsE,intermJumpsE,extraJumps]) $ \(Concealed route caps querys reqBody) -> 425 | linkWith (mapMetaQuery captureEncoding . toMeta) (Prepared route caps querys reqBody) 426 | (u0, urls) <- url newUrls 427 | let transMetaParse = mapMetaQuery captureDecoding . mapMetaRequestBody (mapMany bodyDecoding) 428 | choice :: Event t (Either TrasaErr (Concealed route)) 429 | choice = ffor (leftmost [newUrls, urls, u0 <$ fire]) $ \us -> 430 | parseWith (transMetaParse . toMeta) madeRouter "GET" us Nothing 431 | -- currently ignoring parse failures 432 | (_parseFailures, concealeds) = fanEither choice 433 | actions' :: Event t (Identity (Either (ResponseError route) (FullMonty route))) <- requestMultiWith (metaReflexToMetaClient . toMeta) (fromConcealed <$> concealeds) 434 | let actions = (coerceEvent actions' :: Event t (Either (ResponseError route) (FullMonty route))) 435 | let hidden = M.singleton "style" "display:none;" 436 | jumpsE <- fmap leftmost $ forM routes $ \(Constructed route) -> do 437 | let m = fmap (either (const Nothing) (castRequiem route)) actions 438 | attrs <- holdDyn hidden (fmap (maybe hidden (const M.empty)) m) 439 | let rtStaticAttrs = attrize route 440 | let rtWidg = dynAfter (fmapMaybe id m) (widgetize route) 441 | elDynAttr "div" (fmap (M.unionWith (<>) rtStaticAttrs) attrs) $ do 442 | rtWidg 443 | let merr = fmap (either Just (const Nothing)) actions 444 | errAttrs <- holdDyn hidden (fmap (maybe hidden (const M.empty)) merr) 445 | let (errStaticAttrs,errWidg) = onErr (fmapMaybe id merr) 446 | errJumpsE <- elDynAttr "div" (fmap (M.unionWith (<>) errStaticAttrs) errAttrs) $ do 447 | (errWidg :: m (Event t (Concealed route))) 448 | 449 | let initialRequest :: Event t (Either Url (Either (ResponseError route) (FullMonty route))) 450 | initialRequest = leftmost [Left <$> newUrls, Right <$> actions] 451 | minterm :: Event t (Maybe Url) 452 | minterm = fmap (either Just (const Nothing)) initialRequest 453 | intermAttrs :: Dynamic t (Map Text Text) <- holdDyn hidden (fmap (maybe hidden (const M.empty)) minterm) 454 | intermJumpsE <- elDynAttr "div" intermAttrs $ do 455 | (interm :: m (Event t (Concealed route))) 456 | 457 | return concealeds 458 | where 459 | castRequiem :: route w x y z -> FullMonty route -> Maybe (Requiem w x z) 460 | castRequiem route (FullMonty incomingRoute caps querys theResp) = case testRouteEquality route incomingRoute of 461 | Nothing -> Nothing 462 | Just Refl -> Just (Requiem caps querys theResp) 463 | fromConcealed :: Concealed route -> Identity (ResponseHandler route (FullMonty route)) 464 | fromConcealed (Concealed route caps querys reqBody) = Identity 465 | ( ResponseHandler 466 | (Prepared route caps querys reqBody) 467 | (metaResponseBody (toMeta route)) 468 | (FullMonty route caps querys) 469 | ) 470 | 471 | data FullMonty :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Type where 472 | FullMonty :: 473 | !(route captures querys request response) 474 | -> !(Rec Identity captures) 475 | -> !(Rec Parameter querys) 476 | -> !response 477 | -> FullMonty route 478 | 479 | -------------------------------------------------------------------------------- /trasa-reflex/src/Trasa/Reflex/Implicit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Trasa.Reflex.Implicit 5 | ( 6 | request 7 | , requestMany 8 | , serve 9 | ) where 10 | 11 | import Data.Functor.Identity (Identity) 12 | import Reflex.Dom (MonadWidget,Event) 13 | import Trasa.Core hiding (requestWith) 14 | import Trasa.Core.Implicit 15 | import Trasa.Reflex 16 | 17 | request 18 | :: ( MonadWidget t m 19 | , HasMeta route 20 | , HasCaptureEncoding (CaptureStrategy route) 21 | , HasCaptureEncoding (QueryStrategy route) 22 | , RequestBodyStrategy route ~ Many requestBodyStrat 23 | , HasBodyEncoding requestBodyStrat 24 | , ResponseBodyStrategy route ~ Many responseBodyStrat 25 | , HasBodyDecoding responseBodyStrat 26 | ) 27 | => Event t (Prepared route response) 28 | -> m (Event t (Either (ResponseError route) response)) 29 | request = requestWith (transMeta . meta) 30 | where transMeta = mapMeta captureEncoding captureEncoding (mapMany bodyEncoding) (mapMany bodyDecoding) 31 | 32 | requestMany 33 | :: ( MonadWidget t m 34 | , Traversable f 35 | , HasMeta route 36 | , HasCaptureEncoding (CaptureStrategy route) 37 | , HasCaptureEncoding (QueryStrategy route) 38 | , RequestBodyStrategy route ~ Many requestBodyStrat 39 | , HasBodyEncoding requestBodyStrat 40 | , ResponseBodyStrategy route ~ Many responseBodyStrat 41 | , HasBodyDecoding responseBodyStrat 42 | ) 43 | => Event t (f (Prepared route response)) 44 | -> m (Event t (f (Either (ResponseError route) response))) 45 | requestMany = requestManyWith (transMeta . meta) 46 | where transMeta = mapMeta captureEncoding captureEncoding (mapMany bodyEncoding) (mapMany bodyDecoding) 47 | 48 | serve 49 | :: ( MonadWidget t m 50 | , HasMeta route 51 | , HasCaptureEncoding (CaptureStrategy route) 52 | , HasCaptureDecoding (CaptureStrategy route) 53 | , HasCaptureCodec (QueryStrategy route) 54 | , RequestBodyStrategy route ~ Many requestBodyStrat 55 | , HasBodyCodec requestBodyStrat 56 | , ResponseBodyStrategy route ~ Many responseBodyStrat 57 | , HasBodyDecoding responseBodyStrat 58 | , EnumerableRoute route 59 | ) 60 | => (forall caps qrys req resp. 61 | route caps qrys req resp -> 62 | Rec Identity caps -> 63 | Rec Parameter qrys -> 64 | ResponseBody Identity resp -> 65 | m (Event t (Concealed route))) 66 | -> (ResponseError route -> m (Event t (Concealed route))) 67 | -> m () 68 | serve = serveWith (transMeta . meta) router 69 | where transMeta = mapMeta captureEncoding captureCodec (mapMany bodyCodec) (mapMany bodyDecoding) 70 | -------------------------------------------------------------------------------- /trasa-reflex/trasa-reflex.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: 3 | trasa-reflex 4 | version: 5 | 0.4 6 | synopsis: 7 | Reactive Type-Safe Web Routing 8 | description: 9 | Reflex-FRP integration for trasa 10 | homepage: 11 | https://github.com/haskell-trasa/trasa 12 | author: 13 | Andrew Martin 14 | Kyle McKean 15 | maintainer: 16 | Andrew Martin 17 | Kyle McKean 18 | chessai 19 | license: 20 | MIT 21 | license-file: 22 | LICENSE 23 | copyright: 24 | © 2017-2019 Andrew Martin 25 | © 2017-2019 Kyle McKean 26 | category: 27 | Web, FRP 28 | build-type: 29 | Simple 30 | 31 | library 32 | hs-source-dirs: 33 | src 34 | exposed-modules: 35 | Reflex.PopState 36 | Trasa.Reflex 37 | Trasa.Reflex.Implicit 38 | build-depends: 39 | , base >= 4.9 && < 5 40 | , bytestring == 0.10.* 41 | , text == 1.2.* 42 | , http-types >= 0.9 43 | , http-media >= 0.6 && < 0.8 44 | , containers >= 0.5 && < 0.7 45 | , jsaddle > 0.8 && < 0.10 46 | , ghcjs-dom > 0.7 && < 0.11 47 | , reflex == 0.5.* 48 | , reflex-dom == 0.4.* 49 | , trasa == 0.4.* 50 | , quantification == 0.5.0 51 | default-language: 52 | Haskell2010 53 | 54 | source-repository head 55 | type: git 56 | location: https://github.com/haskell-trasa/trasa 57 | -------------------------------------------------------------------------------- /trasa-server/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017-2019 Andrew Martin 2 | Copyright 2017-2019 Kyle McKean 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 5 | 6 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 9 | -------------------------------------------------------------------------------- /trasa-server/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /trasa-server/src/Trasa/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | 8 | module Trasa.Server 9 | ( TrasaT 10 | , TrasaEnv(..) 11 | , runTrasaT 12 | , mapTrasaT 13 | , serveWith 14 | ) where 15 | 16 | import Control.Applicative (liftA2, Alternative(..)) 17 | import Control.Monad (join, MonadPlus(..)) 18 | import Control.Monad.Except (ExceptT,runExceptT,mapExceptT,MonadError(..),MonadIO(..)) 19 | import Control.Monad.Reader (ReaderT,runReaderT,mapReaderT,MonadReader(..),MonadTrans(..)) 20 | import Control.Monad.State.Strict (StateT,runStateT,mapStateT,MonadState(..)) 21 | import Data.CaseInsensitive (CI) 22 | import Data.Functor.Identity 23 | import Data.Traversable (for) 24 | import Network.HTTP.Types.Header (hAccept,hContentType) 25 | import qualified Data.ByteString as BS 26 | import qualified Data.Map.Strict as M 27 | import qualified Data.Text as T 28 | import qualified Data.Text.Encoding as TE 29 | import qualified Network.HTTP.Media.Accept as N 30 | import qualified Network.HTTP.Media.MediaType as N 31 | import qualified Network.HTTP.Media.RenderHeader as N 32 | import qualified Network.HTTP.Types.Status as N 33 | import qualified Network.Wai as Wai 34 | 35 | import Trasa.Core 36 | 37 | type Headers = M.Map (CI BS.ByteString) T.Text 38 | 39 | data TrasaEnv = TrasaEnv 40 | { trasaHeaders :: Headers 41 | , trasaQueryString :: QueryString 42 | } 43 | 44 | newtype TrasaT m a = TrasaT 45 | { unTrasaT :: ExceptT TrasaErr (StateT Headers (ReaderT TrasaEnv m)) a 46 | } deriving 47 | ( Functor 48 | , Applicative 49 | , Monad 50 | , MonadError TrasaErr 51 | , MonadIO 52 | , MonadState (M.Map (CI BS.ByteString) T.Text) 53 | , MonadReader TrasaEnv 54 | ) 55 | 56 | instance (Monad m, Semigroup a) => Semigroup (TrasaT m a) where 57 | (<>) = liftA2 (<>) 58 | 59 | instance (Monad m, Monoid a) => Monoid (TrasaT m a) where 60 | mempty = pure mempty 61 | 62 | instance (Alternative m, Monad m) => Alternative (TrasaT m) where 63 | empty = lift empty 64 | a <|> b = catchError a (const b) 65 | 66 | instance (Monad m, Alternative m) => MonadPlus (TrasaT m) 67 | 68 | instance MonadTrans TrasaT where 69 | lift = TrasaT . lift . lift . lift 70 | 71 | runTrasaT 72 | :: TrasaT m a 73 | -> M.Map (CI BS.ByteString) T.Text -- ^ Headers 74 | -> QueryString -- ^ Query string parameters 75 | -> m (Either TrasaErr a, M.Map (CI BS.ByteString) T.Text) 76 | runTrasaT trasa headers queryStrings = (flip runReaderT (TrasaEnv headers queryStrings) . flip runStateT M.empty . runExceptT . unTrasaT) trasa 77 | 78 | mapTrasaT :: (forall x. m x -> n x) -> TrasaT m a -> TrasaT n a 79 | mapTrasaT eta = TrasaT . mapExceptT (mapStateT (mapReaderT eta)) . unTrasaT 80 | 81 | serveWith 82 | :: (forall caps qrys req resp. route caps qrys req resp -> MetaServer caps qrys req resp) 83 | -> (forall caps qrys req resp. 84 | route caps qrys req resp 85 | -> Rec Identity caps 86 | -> Rec Parameter qrys 87 | -> RequestBody Identity req 88 | -> TrasaT IO resp) 89 | -- ^ Actions to perform when requests come in 90 | -> Router route -- ^ Router 91 | -> Wai.Application -- ^ Wai Application 92 | serveWith toMeta makeResponse madeRouter = 93 | \req respond -> 94 | case decodeMethod <$> TE.decodeUtf8' (Wai.requestMethod req) of 95 | Left _ -> respond (Wai.responseLBS N.status400 [] "Non utf8 encoded request method") 96 | Right method -> case parseHeaders req of 97 | Left _ -> respond (Wai.responseLBS N.status400 [] "Non utf8 encoded headers") 98 | Right headers -> case parseAccepts headers of 99 | Nothing -> respond (Wai.responseLBS N.status415 [] "Accept header missing or malformed") 100 | Just accepts -> do 101 | content <- for (M.lookup hContentType headers >>= N.parseAccept . TE.encodeUtf8) $ \typ -> 102 | Content typ <$> Wai.strictRequestBody req 103 | let queryStrings = decodeQuery (Wai.queryString req) 104 | url = Url (Wai.pathInfo req) queryStrings 105 | dispatch = dispatchWith toMeta makeResponse madeRouter method accepts url content 106 | runTrasaT dispatch headers queryStrings >>= \case 107 | (resErr,newHeaders) -> case join resErr of 108 | Left (TrasaErr stat errBody) -> 109 | respond (Wai.responseLBS stat (encodeHeaders newHeaders) errBody) 110 | Right (Content typ lbs) -> do 111 | let cType = TE.decodeUtf8 (N.renderHeader typ) 112 | encodedHeaders = encodeHeaders (M.insert hContentType cType newHeaders) 113 | respond (Wai.responseLBS N.status200 encodedHeaders lbs) 114 | where 115 | encodeHeaders = M.toList . fmap TE.encodeUtf8 116 | parseHeaders = traverse TE.decodeUtf8' . M.fromList . Wai.requestHeaders 117 | parseAccepts :: Headers 118 | -> Maybe [N.MediaType] 119 | parseAccepts headers = case M.lookup hAccept headers of 120 | Nothing -> Just ["*/*"] 121 | Just accept -> (traverse N.parseAccept . fmap (TE.encodeUtf8 . T.dropAround (' '==)) . T.splitOn ",") accept 122 | 123 | -------------------------------------------------------------------------------- /trasa-server/src/Trasa/Server/Implicit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Trasa.Server.Implicit 6 | ( 7 | serve 8 | ) where 9 | 10 | import Data.Functor.Identity (Identity) 11 | import qualified Network.Wai as WAI 12 | 13 | import Trasa.Core 14 | import Trasa.Core.Implicit 15 | import Trasa.Server 16 | 17 | serve 18 | :: ( HasMeta route 19 | , HasCaptureDecoding (CaptureStrategy route) 20 | , HasCaptureDecoding (QueryStrategy route) 21 | , RequestBodyStrategy route ~ Many requestBodyStrat 22 | , HasBodyDecoding requestBodyStrat 23 | , ResponseBodyStrategy route ~ Many responseBodyStrat 24 | , HasBodyEncoding responseBodyStrat 25 | , EnumerableRoute route ) 26 | => (forall caps qrys req resp 27 | . route caps qrys req resp 28 | -> Rec Identity caps 29 | -> Rec Parameter qrys 30 | -> RequestBody Identity req 31 | -> TrasaT IO resp) 32 | -> WAI.Application 33 | serve makeResponse = serveWith (transformMeta . meta) makeResponse router 34 | where transformMeta = mapMeta captureDecoding captureDecoding (mapMany bodyDecoding) (mapMany bodyEncoding) 35 | 36 | 37 | -------------------------------------------------------------------------------- /trasa-server/test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE InstanceSigs #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | 11 | import Trasa.Core 12 | import Trasa.Core.Implicit 13 | import qualified Trasa.Method as M 14 | import Trasa.Server 15 | import Trasa.Server.Implicit 16 | import Data.Functor.Identity 17 | import Data.Kind (Type) 18 | import Text.Read (readMaybe) 19 | import Network.Wai.Handler.Warp (withApplication) 20 | import Topaz.Types (Rec(..)) 21 | import qualified Data.Text as T 22 | import qualified Data.ByteString.Lazy.Char8 as LBSC 23 | import qualified Network.HTTP.Client as HC 24 | 25 | main :: IO () 26 | main = do 27 | putStrLn "\nStarting trasa server test suite" 28 | let app = serve handle 29 | withApplication (return app) $ \port -> do 30 | manager <- HC.newManager HC.defaultManagerSettings 31 | attempt manager ("GET http://127.0.0.1:" ++ show port ++ "/") $ \x -> x 32 | { HC.requestHeaders = [("Accept","text/plain"),("ContentType","*/*")] 33 | } 34 | attempt manager ("GET http://127.0.0.1:" ++ show port ++ "/hello") $ \x -> x 35 | { HC.requestHeaders = [("Accept","text/plain"),("ContentType","text/plain")] 36 | } 37 | return () 38 | 39 | attempt :: HC.Manager -> String -> (HC.Request -> HC.Request) -> IO () 40 | attempt mngr url modify = do 41 | req <- HC.parseUrlThrow url 42 | let req' = modify req 43 | _ <- HC.httpLbs req' mngr 44 | return () 45 | 46 | handle :: Route caps qrys req resp -> Rec Identity caps -> Rec Parameter qrys -> RequestBody Identity req -> TrasaT IO resp 47 | handle r = case r of 48 | EmptyR -> \_ _ _ -> return (55 :: Int) 49 | HelloR -> \_ _ _ -> return (67 :: Int) 50 | 51 | data Route :: [Type] -> [Param] -> Bodiedness -> Type -> Type where 52 | EmptyR :: Route '[] '[] Bodyless Int 53 | HelloR :: Route '[] '[] Bodyless Int 54 | AdditionR :: Route '[Int,Int] '[Optional Int] Bodyless Int 55 | IdentityR :: Route '[String] '[] Bodyless String 56 | LeftPadR :: Route '[Int] '[] (Body String) String 57 | TrickyOneR :: Route '[Int] '[] Bodyless String 58 | TrickyTwoR :: Route '[Int,Int] '[] Bodyless String 59 | 60 | instance EnumerableRoute Route where 61 | enumerateRoutes = 62 | [ Constructed HelloR 63 | , Constructed AdditionR 64 | , Constructed IdentityR 65 | , Constructed LeftPadR 66 | , Constructed TrickyOneR 67 | , Constructed TrickyTwoR 68 | , Constructed EmptyR 69 | ] 70 | 71 | instance HasMeta Route where 72 | type CaptureStrategy Route = CaptureCodec 73 | type QueryStrategy Route = CaptureCodec 74 | type RequestBodyStrategy Route = Many BodyCodec 75 | type ResponseBodyStrategy Route = Many BodyCodec 76 | meta :: Route ps qs rq rp -> MetaCodec ps qs rq rp 77 | meta route = metaBuilderToMetaCodec $ case route of 78 | EmptyR -> Meta 79 | end 80 | qend 81 | bodyless (resp bodyInt) M.get 82 | HelloR -> Meta 83 | (match "hello" ./ end) 84 | qend 85 | bodyless (resp bodyInt) M.get 86 | AdditionR -> Meta 87 | (match "add" ./ capture int ./ capture int ./ end) 88 | (optional "more" int .& qend) 89 | bodyless (resp bodyInt) M.get 90 | IdentityR -> Meta 91 | (match "identity" ./ capture string ./ end) 92 | qend 93 | bodyless (resp bodyString) M.get 94 | LeftPadR -> Meta 95 | (match "pad" ./ match "left" ./ capture int ./ end) 96 | qend 97 | (body bodyString) (resp bodyString) M.get 98 | TrickyOneR -> Meta 99 | (match "tricky" ./ capture int ./ match "one" ./ end) 100 | qend 101 | bodyless (resp bodyString) M.get 102 | TrickyTwoR -> Meta 103 | (capture int ./ capture int ./ match "two" ./ end) 104 | qend 105 | bodyless (resp bodyString) M.get 106 | 107 | 108 | int :: CaptureCodec Int 109 | int = CaptureCodec (T.pack . show) (readMaybe . T.unpack) 110 | 111 | string :: CaptureCodec String 112 | string = CaptureCodec T.pack (Just . T.unpack) 113 | 114 | bodyString :: BodyCodec String 115 | bodyString = BodyCodec (pure "text/plain") LBSC.pack (Right . LBSC.unpack) 116 | 117 | bodyUnit :: BodyCodec () 118 | bodyUnit = BodyCodec (pure "text/plain") (const "") (const (Right ())) 119 | 120 | note :: e -> Maybe a -> Either e a 121 | note e Nothing = Left e 122 | note _ (Just x) = Right x 123 | 124 | bodyInt :: BodyCodec Int 125 | bodyInt = BodyCodec (pure "text/plain") (LBSC.pack . show) 126 | (note "Could not decode int" . readMaybe . LBSC.unpack) 127 | -------------------------------------------------------------------------------- /trasa-server/trasa-server.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: 3 | trasa-server 4 | version: 5 | 0.5.4 6 | synopsis: 7 | Type safe web server 8 | description: 9 | WAI integration for trasa 10 | homepage: 11 | https://github.com/haskell-trasa/trasa 12 | author: 13 | Andrew Martin 14 | Kyle McKean 15 | maintainer: 16 | Andrew Martin 17 | Kyle McKean 18 | chessai 19 | license: 20 | MIT 21 | license-file: 22 | LICENSE 23 | copyright: 24 | © 2017-2019 Andrew Martin 25 | © 2017-2019 Kyle McKean 26 | category: 27 | Web 28 | build-type: 29 | Simple 30 | 31 | library 32 | hs-source-dirs: 33 | src 34 | exposed-modules: 35 | Trasa.Server 36 | , Trasa.Server.Implicit 37 | build-depends: 38 | , base >= 4.9 && < 5 39 | , bytestring >= 0.10 && < 0.11 40 | , case-insensitive >= 1.2 && < 1.3 41 | , containers >= 0.5 && < 0.7 42 | , http-media >= 0.6 && < 0.9 43 | , http-types >= 0.9 && < 0.13 44 | , mtl >= 2.2 && < 2.3 45 | , text >= 1.2 && < 1.3 46 | , trasa >= 0.4 && < 0.5 47 | , wai >= 3.2.2 && < 3.3 48 | default-language: 49 | Haskell2010 50 | ghc-options: 51 | -Wall -O2 52 | 53 | --test-suite test 54 | -- type: exitcode-stdio-1.0 55 | -- hs-source-dirs: test 56 | -- main-is: Main.hs 57 | -- build-depends: 58 | -- base 59 | -- , trasa 60 | -- , trasa-server 61 | -- , tasty 62 | -- , tasty-quickcheck 63 | -- , tasty-hunit 64 | -- , bytestring 65 | -- , text 66 | -- , quantification 67 | -- , doctest 68 | -- , warp 69 | -- , http-client 70 | -- default-language: Haskell2010 71 | 72 | source-repository head 73 | type: git 74 | location: https://github.com/haskell-trasa/trasa 75 | -------------------------------------------------------------------------------- /trasa-th/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017-2019 Andrew Martin 2 | Copyright 2017-2019 Kyle McKean 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 5 | 6 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 9 | -------------------------------------------------------------------------------- /trasa-th/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /trasa-th/src/Trasa/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Trasa.TH 8 | ( 9 | Name 10 | , CaptureRep(..) 11 | , ParamRep(..) 12 | , QueryRep(..) 13 | , RouteRep(..) 14 | , RoutesRep(..) 15 | , routeDataType 16 | , enumRoutesInstance 17 | , metaInstance 18 | , trasa 19 | , parseTrasa 20 | )where 21 | 22 | import Data.Kind (Type) 23 | import qualified Data.List.NonEmpty as NE 24 | import Data.Maybe (listToMaybe, mapMaybe) 25 | import Language.Haskell.TH hiding (Type, match) 26 | import qualified Language.Haskell.TH as TH 27 | import Language.Haskell.TH.Quote 28 | import Trasa.Core 29 | import Trasa.Core.Implicit 30 | 31 | import Trasa.TH.Parse (parseRoutesRep) 32 | import Trasa.TH.Types 33 | 34 | genCodec :: Name -> Q CodecRep 35 | genCodec name = reify name >>= \case 36 | VarI fullName fullType _ -> case fullType of 37 | AppT codec typ -> return (CodecRep fullName codec typ) 38 | _ -> fail ("Codec: " ++ show name ++ " does not have a type like (Codec Type) but has the type: " ++ show fullType) 39 | _ -> fail ("Codec: " ++ show name ++ " is not a haskell value") 40 | 41 | genCodecs :: (RoutesRep CodecRep -> Q b) -> RoutesRep Name -> Q b 42 | genCodecs f routeRepNames = do 43 | routeReps <- traverse genCodec routeRepNames 44 | f routeReps 45 | 46 | typeList :: [TH.Type] -> TH.Type 47 | typeList = foldr (\typ rest -> PromotedConsT `AppT` typ `AppT` rest) PromotedNilT 48 | 49 | routeDataTypeCodec :: RoutesRep CodecRep -> Q Dec 50 | routeDataTypeCodec (RoutesRep routeStr routeReps) = do 51 | kind <- [t| [Type] -> [Param] -> Bodiedness -> Type -> Type |] 52 | return (DataD [] route [] (Just kind) (fmap (buildCons route) routeReps) []) 53 | where 54 | route = mkName routeStr 55 | buildCons :: Name -> RouteRep CodecRep -> Con 56 | buildCons rt (RouteRep name _ captures queries request response) = GadtC [mkName name] [] typ 57 | where 58 | typ = 59 | ConT rt `AppT` 60 | typeList (mapMaybe captureType captures) `AppT` 61 | typeList (fmap (paramType . queryRepParam) queries) `AppT` 62 | bodiednessType request `AppT` 63 | responseType response 64 | captureType :: CaptureRep CodecRep -> Maybe TH.Type 65 | captureType = \case 66 | MatchRep _ -> Nothing 67 | CaptureRep (CodecRep _ _ typ) -> Just typ 68 | paramType :: ParamRep CodecRep -> TH.Type 69 | paramType = \case 70 | FlagRep -> PromotedT 'Flag 71 | OptionalRep (CodecRep _ _ typ) -> PromotedT 'Optional `AppT` typ 72 | ListRep (CodecRep _ _ typ) -> PromotedT 'List `AppT` typ 73 | bodiednessType :: [CodecRep] -> TH.Type 74 | bodiednessType = \case 75 | [] -> PromotedT 'Bodyless 76 | (CodecRep _ _ typ:_) -> PromotedT 'Body `AppT` typ 77 | responseType = \case 78 | (CodecRep _ _ typ NE.:| _) -> typ 79 | 80 | routeDataType :: RoutesRep Name -> Q Dec 81 | routeDataType = genCodecs routeDataTypeCodec 82 | 83 | enumRoutesInstanceCodec :: RoutesRep CodecRep -> Dec 84 | enumRoutesInstanceCodec (RoutesRep routeStr routeReps) = 85 | InstanceD Nothing [] typ [FunD 'enumerateRoutes [Clause [] (NormalB (ListE expr)) []]] 86 | where 87 | route = mkName routeStr 88 | typ = ConT ''EnumerableRoute `AppT` ConT route 89 | buildCons name = ConE 'Constructed `AppE` ConE (mkName name) 90 | expr = fmap (buildCons . routeRepName) routeReps 91 | 92 | enumRoutesInstance :: RoutesRep Name -> Q Dec 93 | enumRoutesInstance = genCodecs (return . enumRoutesInstanceCodec) 94 | 95 | metaInstanceCodec :: RoutesRep CodecRep -> Q Dec 96 | metaInstanceCodec (RoutesRep routeStr routeReps) = do 97 | let route = mkName routeStr 98 | typ = ConT ''HasMeta `AppT` ConT route 99 | capStrat <- search routeRepCaptures capCodec [t| CaptureCodec |] 100 | qryStrat <- search routeRepQueries (paramCodec . queryRepParam) [t| CaptureCodec |] 101 | reqBodyStrat <- search routeReqRequest (Just . codecRepCodec) [t| BodyCodec |] 102 | respBodyStrat <- search (NE.toList . routeReqResponse) (Just . codecRepCodec) [t| BodyCodec |] 103 | many <- [t| Many |] 104 | #if !MIN_VERSION_template_haskell(2,15,0) 105 | let mkTypeFamily str strat = TySynInstD (mkName str) (TySynEqn [ConT route] strat) 106 | #else 107 | let mkTypeFamily str strat = TySynInstD (TySynEqn (Just [PlainTV (mkName str)]) (ConT route) strat) 108 | #endif 109 | typeFamilies = 110 | [ mkTypeFamily "CaptureStrategy" capStrat 111 | , mkTypeFamily "QueryStrategy" qryStrat 112 | , mkTypeFamily "RequestBodyStrategy" (many `AppT` reqBodyStrat) 113 | , mkTypeFamily "ResponseBodyStrategy" (many `AppT` respBodyStrat) 114 | ] 115 | lam <- newName "route" 116 | let metaExp = LamE [VarP lam] (CaseE (VarE lam) (fmap routeRepToMetaPattern routeReps)) 117 | metaFunction = FunD 'meta [Clause [] (NormalB metaExp) []] 118 | return (InstanceD Nothing [] typ (typeFamilies ++ [metaFunction])) 119 | where 120 | search :: (RouteRep CodecRep -> [b]) -> (b -> Maybe TH.Type) -> Q TH.Type -> Q TH.Type 121 | search f g err = case listToMaybe (mapMaybe g (routeReps >>= f)) of 122 | Just t -> return t 123 | Nothing -> err 124 | capCodec :: CaptureRep CodecRep -> Maybe TH.Type 125 | capCodec = \case 126 | MatchRep _ -> Nothing 127 | CaptureRep (CodecRep _ codec _) -> Just codec 128 | paramCodec :: ParamRep CodecRep -> Maybe TH.Type 129 | paramCodec = \case 130 | FlagRep -> Nothing 131 | OptionalRep (CodecRep _ codec _) -> Just codec 132 | ListRep (CodecRep _ codec _) -> Just codec 133 | routeRepToMetaPattern :: RouteRep CodecRep -> Match 134 | routeRepToMetaPattern (RouteRep name method caps qrys req res) = 135 | Match (ConP (mkName name) []) (NormalB expr) [] 136 | where 137 | expr = 138 | ConE 'Meta `AppE` 139 | capsE `AppE` 140 | qrysE `AppE` 141 | reqE `AppE` 142 | respE `AppE` 143 | methodE 144 | capsE = foldr (\cp -> UInfixE (captureRepToExp cp) (VarE '(./))) (VarE 'end) caps 145 | captureRepToExp = \case 146 | MatchRep str -> VarE 'match `AppE` LitE (StringL str) 147 | CaptureRep (CodecRep n _ _) -> VarE 'capture `AppE` VarE n 148 | qrysE = foldr (\qp -> UInfixE (queryRepToExp qp) (VarE '(.&))) (VarE 'qend) qrys 149 | queryRepToExp (QueryRep idt param) = case param of 150 | FlagRep -> VarE 'flag `AppE` lit 151 | OptionalRep (CodecRep n _ _) -> VarE 'optional `AppE` lit `AppE` VarE n 152 | ListRep (CodecRep n _ _) -> VarE 'list `AppE` lit `AppE` VarE n 153 | where lit = LitE (StringL idt) 154 | reqE = case req of 155 | [] -> VarE 'bodyless 156 | (r : rs) -> VarE 'body `AppE` manyE (r NE.:| rs) 157 | respE = VarE 'resp `AppE` manyE res 158 | methodE = LitE (StringL method) 159 | manyE (CodecRep n _ _ NE.:| xs) = 160 | ConE 'Many `AppE` (UInfixE (VarE n) (ConE '(NE.:|)) (ListE (VarE . codecRepName <$> xs))) 161 | 162 | metaInstance :: RoutesRep Name -> Q Dec 163 | metaInstance = genCodecs metaInstanceCodec 164 | 165 | trasa :: RoutesRep Name -> Q [Dec] 166 | trasa routeRepNames = do 167 | routeReps <- traverse genCodec routeRepNames 168 | rt <- routeDataTypeCodec routeReps 169 | let cons = enumRoutesInstanceCodec routeReps 170 | m <- metaInstanceCodec routeReps 171 | return [rt, cons, m] 172 | 173 | parseTrasa :: QuasiQuoter 174 | parseTrasa = QuasiQuoter err err err quoter 175 | where 176 | err _ = fail "parseTrasa: This quasi quoter should only be used on the top level" 177 | quoter :: String -> Q [Dec] 178 | quoter str = case parseRoutesRep str of 179 | Left e -> fail e 180 | Right routeRepNames -> trasa routeRepNames 181 | -------------------------------------------------------------------------------- /trasa-th/src/Trasa/TH/Lexer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE ExplicitForAll #-} 4 | {-# LANGUAGE MultiWayIf #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | 9 | module Trasa.TH.Lexer 10 | ( ReservedChar(..) 11 | , ReservedSymbol(..) 12 | , Lexeme(..) 13 | , Stream(..) 14 | , stream ) where 15 | 16 | import Data.Proxy (Proxy(..)) 17 | import Data.Semigroup ((<>)) 18 | import Data.Void (Void) 19 | import Data.Coerce 20 | import qualified Data.List.NonEmpty as NE 21 | import qualified Data.List as L 22 | import qualified Text.Megaparsec as MP 23 | import qualified Text.Megaparsec.Char as MP 24 | import qualified Text.Megaparsec.Stream as MP 25 | 26 | type Parser a = MP.Parsec Void String a 27 | 28 | instance Ord a => MP.ShowErrorComponent (MP.ErrorFancy a) where 29 | showErrorComponent (MP.ErrorFail e) = e 30 | showErrorComponent (MP.ErrorCustom _) = "undefined error" 31 | 32 | data ReservedChar 33 | = ReservedCharNewline 34 | | ReservedCharColon 35 | | ReservedCharSlash 36 | | ReservedCharQuestionMark 37 | | ReservedCharAmpersand 38 | | ReservedCharEqual 39 | | ReservedCharOpenBracket 40 | | ReservedCharCloseBracket 41 | | ReservedCharComma 42 | | ReservedCharTab 43 | deriving (Show,Eq,Ord) 44 | 45 | data ReservedSymbol 46 | = ReservedSymbolDataType 47 | deriving (Show,Eq,Ord) 48 | 49 | data Lexeme 50 | = LexemeSpace Word 51 | | LexemeChar ReservedChar 52 | | LexemeSymbol ReservedSymbol 53 | | LexemeString Word String 54 | deriving (Show,Eq,Ord) 55 | 56 | newtype Stream = Stream [Lexeme] 57 | deriving (Eq, Ord, Show, Monoid, Semigroup) 58 | 59 | instance MP.Stream Stream where 60 | type Token Stream = Lexeme 61 | type Tokens Stream = [Lexeme] 62 | tokenToChunk Proxy = pure 63 | tokensToChunk Proxy = id 64 | chunkToTokens Proxy = id 65 | chunkLength Proxy = length 66 | chunkEmpty Proxy = null 67 | take1_ (Stream []) = Nothing 68 | take1_ (Stream (t:ts)) = Just (t, Stream ts) 69 | takeN_ n (Stream s) 70 | | n <= 0 = Just ([], Stream s) 71 | | null s = Nothing 72 | | otherwise = Just $ coerce (splitAt n s) 73 | takeWhile_ = coerce . span 74 | -- NOTE Do not eta-reduce these (breaks inlining) 75 | reachOffset o pst = reachOffset' (\n (Stream l) -> coerce $ splitAt n l) L.foldl' (fmap prettyCharToken . coerce) (prettyCharToken . coerce) (coerce $ LexemeChar ReservedCharNewline, coerce $ LexemeChar ReservedCharTab) o (coerce pst) 76 | showTokens _ = L.concatMap prettyToken . NE.toList 77 | 78 | prettyCharToken = \case 79 | LexemeSpace _ -> ' ' 80 | LexemeChar resChar -> case resChar of 81 | ReservedCharNewline -> '\n' 82 | ReservedCharColon -> ':' 83 | ReservedCharSlash -> '/' 84 | ReservedCharQuestionMark -> '?' 85 | ReservedCharAmpersand -> '&' 86 | ReservedCharEqual -> '=' 87 | ReservedCharOpenBracket -> '[' 88 | ReservedCharCloseBracket -> ']' 89 | ReservedCharComma -> ',' 90 | ReservedCharTab -> '\t' 91 | LexemeSymbol sym -> case sym of 92 | ReservedSymbolDataType -> 'd' 93 | LexemeString _ _ -> 's' 94 | 95 | prettyToken = \case 96 | LexemeSpace _ -> "space(s)" 97 | LexemeChar resChar -> case resChar of 98 | ReservedCharNewline -> "newline" 99 | ReservedCharColon -> ":" 100 | ReservedCharSlash -> "/" 101 | ReservedCharQuestionMark -> "?" 102 | ReservedCharAmpersand -> "&" 103 | ReservedCharEqual -> "=" 104 | ReservedCharOpenBracket -> "[" 105 | ReservedCharCloseBracket -> "]" 106 | ReservedCharComma -> "," 107 | ReservedCharTab -> "tab" 108 | LexemeSymbol sym -> case sym of 109 | ReservedSymbolDataType -> "data-type" 110 | LexemeString _ _ -> "any string" 111 | 112 | lexeme :: Parser Lexeme 113 | lexeme = MP.choice 114 | [ LexemeSpace . fromIntegral . length <$> MP.some (MP.char ' ') 115 | , LexemeChar <$> MP.choice 116 | [ ReservedCharNewline <$ MP.char '\n' 117 | , ReservedCharColon <$ MP.char ':' 118 | , ReservedCharSlash <$ MP.char '/' 119 | , ReservedCharQuestionMark <$ MP.char '?' 120 | , ReservedCharAmpersand <$ MP.char '&' 121 | , ReservedCharEqual <$ MP.char '=' 122 | , ReservedCharOpenBracket <$ MP.char '[' 123 | , ReservedCharCloseBracket <$ MP.char ']' 124 | , ReservedCharComma <$ MP.char ',' 125 | ] 126 | , LexemeSymbol <$> MP.choice 127 | [ ReservedSymbolDataType <$ MP.string "data-type" 128 | ] 129 | , string <$> MP.some (MP.noneOf " \n:/?&=[],") 130 | ] 131 | where string str = LexemeString (fromIntegral (length str)) str 132 | 133 | data St = St MP.SourcePos ShowS 134 | 135 | reachOffset' 136 | :: (Int -> Stream -> (MP.Tokens Stream, Stream)) 137 | -- ^ How to split input stream at given offset 138 | -> (forall b. (b -> MP.Token Stream -> b) -> b -> MP.Tokens Stream -> b) 139 | -- ^ How to fold over input stream 140 | -> (MP.Tokens Stream -> String) 141 | -- ^ How to convert chunk of input stream into a 'String' 142 | -> (MP.Token Stream -> Char) 143 | -- ^ How to convert a token into a 'Char' 144 | -> (MP.Token Stream, MP.Token Stream) 145 | -- ^ Newline token and tab token 146 | -> Int 147 | -- ^ Offset to reach 148 | -> MP.PosState Stream 149 | -- ^ Initial 'MP.PosState' to use 150 | -> (MP.SourcePos, String, MP.PosState Stream) 151 | -- ^ Reached 'SourcePos', line at which 'SourcePos' is located, updated 152 | -- 'MP.PosState' 153 | reachOffset' splitAt' 154 | foldl'' 155 | fromToks 156 | fromTok 157 | (newlineTok, tabTok) 158 | o 159 | MP.PosState {..} = 160 | ( spos 161 | , case expandTab pstateTabWidth 162 | . addPrefix 163 | . f 164 | . fromToks 165 | . fst 166 | $ MP.takeWhile_ (/= newlineTok) post of 167 | "" -> "" 168 | xs -> xs 169 | , MP.PosState 170 | { MP.pstateInput = post 171 | , MP.pstateOffset = max pstateOffset o 172 | , MP.pstateSourcePos = spos 173 | , MP.pstateTabWidth = pstateTabWidth 174 | , MP.pstateLinePrefix = 175 | if sameLine 176 | -- NOTE We don't use difference lists here because it's 177 | -- desirable for 'MP.PosState' to be an instance of 'Eq' and 178 | -- 'Show'. So we just do appending here. Fortunately several 179 | -- parse errors on the same line should be relatively rare. 180 | then pstateLinePrefix ++ f "" 181 | else f "" 182 | } 183 | ) 184 | where 185 | addPrefix xs = 186 | if sameLine 187 | then pstateLinePrefix ++ xs 188 | else xs 189 | sameLine = MP.sourceLine spos == MP.sourceLine pstateSourcePos 190 | (pre, post) = splitAt' (o - pstateOffset) pstateInput 191 | St spos f = foldl'' go (St pstateSourcePos id) pre 192 | go (St apos g) ch = 193 | let MP.SourcePos n l c = apos 194 | c' = MP.unPos c 195 | w = MP.unPos pstateTabWidth 196 | in if | ch == newlineTok -> 197 | St (MP.SourcePos n (l <> MP.pos1) MP.pos1) 198 | id 199 | | ch == tabTok -> 200 | St (MP.SourcePos n l (MP.mkPos $ c' + w - ((c' - 1) `rem` w))) 201 | (g . (fromTok ch :)) 202 | | otherwise -> 203 | St (MP.SourcePos n l (c <> MP.pos1)) 204 | (g . (fromTok ch :)) 205 | {-# INLINE reachOffset' #-} 206 | 207 | expandTab 208 | :: MP.Pos 209 | -> String 210 | -> String 211 | expandTab w' = go 0 212 | where 213 | go 0 [] = [] 214 | go 0 ('\t':xs) = go w xs 215 | go 0 (x:xs) = x : go 0 xs 216 | go n xs = ' ' : go (n - 1) xs 217 | w = MP.unPos w' 218 | 219 | stream :: Parser Stream 220 | stream = Stream <$> MP.many lexeme 221 | -------------------------------------------------------------------------------- /trasa-th/src/Trasa/TH/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Trasa.TH.Parse where 3 | 4 | import qualified Data.List.NonEmpty as NE 5 | import qualified Data.Set as S 6 | import Data.Bifunctor (first) 7 | import Language.Haskell.TH (Name,mkName) 8 | import Control.Applicative ((<|>)) 9 | import Control.Monad (void) 10 | import Data.Void (Void) 11 | import qualified Text.Megaparsec as MP 12 | import qualified Text.Megaparsec.Char.Lexer as L 13 | 14 | import Trasa.TH.Types 15 | import Trasa.TH.Lexer 16 | 17 | import Debug.Trace 18 | 19 | type Parser = MP.Parsec (MP.ErrorFancy Void) Stream 20 | 21 | wrongToken :: a -> S.Set (MP.ErrorItem a) 22 | wrongToken t = S.singleton (MP.Tokens (t NE.:| [])) 23 | 24 | space :: Parser () 25 | space = flip MP.token (wrongToken $ LexemeSpace 0) $ \case 26 | LexemeSpace _ -> Just () 27 | other -> Nothing 28 | 29 | optionalSpace :: Parser () 30 | optionalSpace = void (MP.optional space) 31 | 32 | string :: Parser String 33 | string = flip MP.token (wrongToken (LexemeString 0 "")) $ \case 34 | LexemeString _ str -> Just str 35 | other -> Nothing 36 | 37 | name :: Parser Name 38 | name = fmap mkName string 39 | 40 | match :: Lexeme -> Parser () 41 | match lexeme = flip MP.token (wrongToken lexeme) $ \other -> 42 | if lexeme == other 43 | then Just () 44 | else Nothing 45 | 46 | matchChar :: ReservedChar -> Parser () 47 | matchChar = match . LexemeChar 48 | 49 | newline :: Parser () 50 | newline = matchChar ReservedCharNewline 51 | 52 | colon :: Parser () 53 | colon = matchChar ReservedCharColon 54 | 55 | slash :: Parser () 56 | slash = matchChar ReservedCharSlash 57 | 58 | questionMark :: Parser () 59 | questionMark = matchChar ReservedCharQuestionMark 60 | 61 | ampersand :: Parser () 62 | ampersand = matchChar ReservedCharAmpersand 63 | 64 | equal :: Parser () 65 | equal = matchChar ReservedCharEqual 66 | 67 | bracket :: Parser a -> Parser a 68 | bracket = MP.between (matchChar ReservedCharOpenBracket) (matchChar ReservedCharCloseBracket) 69 | 70 | comma :: Parser () 71 | comma = matchChar ReservedCharComma 72 | 73 | capture :: Parser (CaptureRep Name) 74 | capture = 75 | fmap MatchRep string <|> 76 | fmap CaptureRep (colon *> name) 77 | 78 | query :: Parser [QueryRep Name] 79 | query = MP.sepBy (QueryRep <$> string <*> paramRep) ampersand 80 | where 81 | paramRep = MP.choice [ fmap OptionalRep optional, fmap ListRep list, pure FlagRep ] 82 | optional = MP.try (equal *> name) 83 | list = equal *> bracket name 84 | 85 | list :: Parser a -> Parser [a] 86 | list val = bracket (MP.sepBy val (optionalSpace *> comma <* optionalSpace)) 87 | 88 | response :: Parser (NE.NonEmpty Name) 89 | response = list name >>= \case 90 | [] -> fail "Response requires at least one response type in the list" 91 | (n : ns) -> pure (n NE.:| ns) 92 | 93 | routeRep :: Parser (RouteRep Name) 94 | routeRep = do 95 | optionalSpace 96 | routeId <- string 97 | space 98 | method <- string 99 | space 100 | slash 101 | caps <- MP.sepBy capture slash 102 | qrys <- questionMark *> query <|> return [] 103 | space 104 | req <- list name 105 | space 106 | res <- response 107 | optionalSpace 108 | newline 109 | return (RouteRep routeId method caps qrys req res) 110 | 111 | routesRep :: Parser (RoutesRep Name) 112 | routesRep = do 113 | optionalSpace 114 | void (MP.optional newline) 115 | optionalSpace 116 | match (LexemeSymbol ReservedSymbolDataType) 117 | colon 118 | optionalSpace 119 | dataType <- string 120 | newline 121 | routes <- MP.many routeRep 122 | return (RoutesRep dataType routes) 123 | 124 | parseRoutesRep :: String -> Either String (RoutesRep Name) 125 | parseRoutesRep str = do 126 | tokens <- first MP.errorBundlePretty (MP.parse stream "" str) 127 | first MP.errorBundlePretty (MP.parse routesRep "" (traceShowId tokens)) 128 | -------------------------------------------------------------------------------- /trasa-th/src/Trasa/TH/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | module Trasa.TH.Types where 3 | 4 | import qualified Data.List.NonEmpty as NE 5 | import Language.Haskell.TH 6 | 7 | data CodecRep = CodecRep 8 | { codecRepName :: Name 9 | , codecRepCodec :: Type 10 | , codecRepType :: Type 11 | } deriving Show 12 | 13 | data CaptureRep codecRep 14 | = MatchRep String 15 | | CaptureRep codecRep 16 | deriving (Show,Foldable,Functor,Traversable) 17 | 18 | data ParamRep codecRep 19 | = FlagRep 20 | | OptionalRep codecRep 21 | | ListRep codecRep 22 | deriving (Show,Foldable,Functor,Traversable) 23 | 24 | data QueryRep codecRep = QueryRep 25 | { queryRepKey :: String 26 | , queryRepParam :: ParamRep codecRep 27 | } deriving (Show,Foldable,Functor,Traversable) 28 | 29 | data RouteRep codecRep = RouteRep 30 | { routeRepName :: String 31 | , routeRepMethod :: String 32 | , routeRepCaptures :: [CaptureRep codecRep] 33 | , routeRepQueries :: [QueryRep codecRep] 34 | , routeReqRequest :: [codecRep] 35 | , routeReqResponse :: NE.NonEmpty codecRep 36 | } deriving (Show,Foldable,Functor,Traversable) 37 | 38 | data RoutesRep codecRep = RoutesRep 39 | { routesRepName :: String 40 | , routesRepRoutes :: [RouteRep codecRep] 41 | } deriving (Show,Foldable,Functor,Traversable) 42 | -------------------------------------------------------------------------------- /trasa-th/test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE DataKinds #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# OPTIONS_GHC -Wall -Werror -ddump-splices #-} 8 | module Main where 9 | 10 | import Data.List.NonEmpty 11 | import Trasa.Core 12 | import Trasa.Core.Implicit 13 | import Trasa.TH 14 | 15 | int :: CaptureEncoding Int 16 | int = captureCodecToCaptureEncoding showReadCaptureCodec 17 | 18 | bodyInt :: BodyCodec Int 19 | bodyInt = showReadBodyCodec 20 | 21 | bodyString :: BodyCodec String 22 | bodyString = showReadBodyCodec 23 | 24 | bodyUnit :: BodyCodec () 25 | bodyUnit = showReadBodyCodec 26 | 27 | $(trasa ( 28 | RoutesRep 29 | "Route" 30 | [ RouteRep 31 | "Add" 32 | "GET" 33 | [MatchRep "add",CaptureRep 'int, CaptureRep 'int] 34 | [QueryRep "third" (OptionalRep 'int)] 35 | [] 36 | ('bodyInt :| []) 37 | , RouteRep 38 | "Blog" 39 | "POST" 40 | [MatchRep "blog"] 41 | [QueryRep "id" (ListRep 'int)] 42 | ['bodyString] 43 | ('bodyUnit :| []) 44 | ])) 45 | 46 | 47 | [parseTrasa| 48 | data-type: ParsedRoute 49 | ParsedAdd GET /add/:int/:int?third=int [] [bodyInt] 50 | ParsedBlog POST /?id=int [bodyString] [bodyUnit] 51 | |] 52 | 53 | main :: IO () 54 | main = do 55 | print (link (prepare Add 1 1 (Just 1))) 56 | print (link (prepare Blog [1,2,3] "This is a post")) 57 | -------------------------------------------------------------------------------- /trasa-th/trasa-th.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: 3 | trasa-th 4 | version: 5 | 0.4 6 | synopsis: 7 | Template Haskell to generate trasa routes 8 | description: 9 | Trasa routes can sometimes be tedious to write out by hand, so `trasa-th` 10 | offers some `-XTemplateHaskell`-based help to generate your `Route` 11 | GADT. 12 | homepage: 13 | https://github.com/haskell-trasa/trasa 14 | author: 15 | Andrew Martin 16 | Kyle McKean 17 | maintainer: 18 | Andrew Martin 19 | Kyle McKean 20 | chessai 21 | license: 22 | MIT 23 | license-file: 24 | LICENSE 25 | copyright: 26 | © 2017-2019 Andrew Martin 27 | © 2017-2019 Kyle McKean 28 | category: 29 | Web 30 | build-type: 31 | Simple 32 | 33 | library 34 | hs-source-dirs: 35 | src 36 | exposed-modules: 37 | Trasa.TH 38 | Trasa.TH.Lexer 39 | Trasa.TH.Parse 40 | Trasa.TH.Types 41 | build-depends: 42 | , base >= 4.9 && < 5.0 43 | , template-haskell >= 2.12 && < 2.17 44 | , containers >= 0.5 && < 0.7 45 | , megaparsec == 7.* 46 | , trasa == 0.4.* 47 | default-language: 48 | Haskell2010 49 | 50 | test-suite test 51 | type: 52 | exitcode-stdio-1.0 53 | hs-source-dirs: 54 | test 55 | main-is: 56 | Main.hs 57 | build-depends: 58 | , base 59 | , trasa 60 | , trasa-th 61 | ghc-options: 62 | -threaded -rtsopts -with-rtsopts=-N 63 | default-language: 64 | Haskell2010 65 | -------------------------------------------------------------------------------- /trasa-tutorial/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017-2019 Andrew Martin 2 | Copyright 2017-2019 Kyle McKean 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 5 | 6 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 9 | -------------------------------------------------------------------------------- /trasa-tutorial/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /trasa-tutorial/cachix.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | nix-build -j1 -Q && nix-store -qR result | cachix push layer-3-cachix 6 | -------------------------------------------------------------------------------- /trasa-tutorial/src/Trasa/Tutorial.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 2 | 3 | {-| Users of this library should create a data type representing all possible 4 | routes available in a web application. It is recommended that 5 | this type be named @Route@, but this is not required. 6 | -} 7 | 8 | module Trasa.Tutorial 9 | ( -- * Dispatch and Routing 10 | -- $dispatchandrouting 11 | ) where 12 | 13 | import Data.Kind (Type) 14 | import Data.Text (Text) 15 | import Trasa.Core 16 | import qualified Trasa.Method as M 17 | 18 | -- $setup 19 | -- >>> :set -XDataKinds 20 | -- >>> :set -XKindSignatures 21 | -- >>> :set -XGADTs 22 | -- >>> :set -XOverloadedStrings 23 | 24 | -- $dispatchandrouting 25 | -- In this example, we will write web application that maintains three 26 | -- counters. The end user will be able to perform various operations 27 | -- that manipulate the values of these counters and ask for their 28 | -- current value. We begin by defining our route type: 29 | -- 30 | -- >>> :{ 31 | -- data Counter = Red | Green | Blue 32 | -- deriving (Show,Read) 33 | -- data Route :: [Type] -> [Param] -> Bodiedness -> Type -> Type where 34 | -- AssignR :: Route '[Counter,Int] '[] 'Bodyless () 35 | -- IncrementR :: Route '[Counter] '[] 'Bodyless Int 36 | -- QueryR :: Route '[Counter] '[]Bodyless Int 37 | -- TotalR :: Route '[] '[] 'Bodyless Int 38 | -- int :: CaptureCodec Int 39 | -- int = showReadCaptureCodec 40 | -- counter :: CaptureCodec Counter 41 | -- counter = showReadCaptureCodec 42 | -- bodyUnit :: BodyCodec () 43 | -- bodyUnit = BodyCodec (pure "text/plain") (const "") (const (Right ())) 44 | -- bodyInt :: BodyCodec Int 45 | -- bodyInt = showReadBodyCodec 46 | -- meta :: Route captures querys request response -> MetaCodec captures querys request response 47 | -- meta x = metaBuilderToMetaCodec $ case x of 48 | -- AssignR -> Meta 49 | -- (match "assign" ./ capture counter ./ match "to" ./ capture int ./ end) 50 | -- qend 51 | -- bodyless (resp bodyUnit) M.post 52 | -- IncrementR -> Meta 53 | -- (match "increment" ./ capture counter ./ end) 54 | -- qend 55 | -- bodyless (resp bodyInt) M.post 56 | -- QueryR -> Meta 57 | -- (match "query" ./ capture counter ./ end) 58 | -- qend 59 | -- bodyless (resp bodyInt) M.get 60 | -- TotalR -> Meta 61 | -- (match "total" ./ end) 62 | -- qend 63 | -- bodyless (resp bodyInt) M.get 64 | -- :} 65 | -- 66 | -- Now, we can start using our routes. To do this, we take functions that 67 | -- @trasa@ exports and partially apply them to the route metadata that 68 | -- we have created. We can start with prepare and link: 69 | -- 70 | -- >>> prepare = prepareWith meta 71 | -- >>> :t prepare 72 | -- prepare 73 | -- :: Route captures query request response 74 | -- -> Arguments captures query request (Prepared Route response) 75 | -- >>> :{ 76 | -- link = linkWith (metaCodecToMetaClient . meta) 77 | -- :} 78 | -- 79 | -- >>> :t link 80 | -- link :: Prepared Route response -> Url 81 | -- 82 | -- Now we can use link to encode our routes: 83 | -- 84 | -- >>> link (prepare AssignR Green 5) 85 | -- "/assign/Green/to/5" 86 | -- 87 | -- 88 | -------------------------------------------------------------------------------- /trasa-tutorial/trasa-tutorial.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: 3 | trasa-tutorial 4 | version: 5 | 0.4 6 | synopsis: 7 | Type-Safe Web Routing Tutorial 8 | description: 9 | Tutorial module/docs for trasa 10 | homepage: 11 | https://github.com/haskell-trasa/trasa 12 | author: 13 | Andrew Martin 14 | Kyle McKean 15 | license: 16 | MIT 17 | license-file: 18 | LICENSE 19 | copyright: 20 | © 2017-2019 Andrew Martin 21 | © 2017-2019 Kyle McKean 22 | category: 23 | Web 24 | build-type: 25 | Simple 26 | 27 | library 28 | hs-source-dirs: 29 | src 30 | exposed-modules: 31 | Trasa.Tutorial 32 | build-depends: 33 | , base >= 4.9 && < 5 34 | , text == 1.2.* 35 | , trasa == 0.4.* 36 | default-language: 37 | Haskell2010 38 | 39 | source-repository head 40 | type: git 41 | location: https://github.com/haskell-trasa/trasa 42 | -------------------------------------------------------------------------------- /trasa/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017-2019 Andrew Martin 2 | Copyright 2017-2019 Kyle McKean 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 5 | 6 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 9 | -------------------------------------------------------------------------------- /trasa/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /trasa/cachix.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | nix-build -j1 -Q && nix-store -qR result | cachix push layer-3-cachix 6 | -------------------------------------------------------------------------------- /trasa/src/Trasa/Codec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Trasa.Codec 4 | ( 5 | -- * Capture Codecs 6 | CaptureEncoding(..) 7 | , HasCaptureEncoding(..) 8 | , CaptureDecoding(..) 9 | , HasCaptureDecoding(..) 10 | , CaptureCodec(..) 11 | , HasCaptureCodec(..) 12 | , captureCodecToCaptureEncoding 13 | , captureCodecToCaptureDecoding 14 | -- * Body Codecs 15 | , BodyEncoding(..) 16 | , HasBodyEncoding(..) 17 | , BodyDecoding(..) 18 | , HasBodyDecoding(..) 19 | , BodyCodec(..) 20 | , HasBodyCodec(..) 21 | , bodyCodecToBodyEncoding 22 | , bodyCodecToBodyDecoding 23 | -- * Type Class Based Codecs 24 | , showReadCaptureCodec 25 | , showReadBodyCodec 26 | , jsonCaptureCodec 27 | , jsonBodyCodec 28 | ) where 29 | 30 | import Data.Aeson (FromJSON, ToJSON) 31 | import Data.Bifunctor (first) 32 | import Data.List.NonEmpty (NonEmpty) 33 | import Text.Read (readMaybe,readEither) 34 | import qualified Data.Aeson as A 35 | import qualified Data.ByteString.Lazy as LBS 36 | import qualified Data.ByteString.Lazy.Char8 as LBC 37 | import qualified Data.Text as T 38 | import qualified Data.Text.Encoding as T 39 | import qualified Network.HTTP.Media.MediaType as N 40 | 41 | newtype CaptureEncoding a = CaptureEncoding { appCaptureEncoding :: a -> T.Text } 42 | 43 | class HasCaptureEncoding capStrategy where 44 | captureEncoding :: capStrategy a -> CaptureEncoding a 45 | 46 | instance HasCaptureEncoding CaptureEncoding where 47 | captureEncoding = id 48 | 49 | newtype CaptureDecoding a = CaptureDecoding { appCaptureDecoding :: T.Text -> Maybe a } 50 | 51 | class HasCaptureDecoding capStrategy where 52 | captureDecoding :: capStrategy a -> CaptureDecoding a 53 | 54 | instance HasCaptureDecoding CaptureDecoding where 55 | captureDecoding = id 56 | 57 | data CaptureCodec a = CaptureCodec 58 | { captureCodecEncode :: a -> T.Text 59 | , captureCodecDecode :: T.Text -> Maybe a 60 | } 61 | 62 | class HasCaptureCodec capStrategy where 63 | captureCodec :: capStrategy a -> CaptureCodec a 64 | 65 | instance HasCaptureEncoding CaptureCodec where 66 | captureEncoding = captureCodecToCaptureEncoding 67 | 68 | instance HasCaptureDecoding CaptureCodec where 69 | captureDecoding = captureCodecToCaptureDecoding 70 | 71 | instance HasCaptureCodec CaptureCodec where 72 | captureCodec = id 73 | 74 | captureCodecToCaptureEncoding :: CaptureCodec a -> CaptureEncoding a 75 | captureCodecToCaptureEncoding (CaptureCodec enc _) = CaptureEncoding enc 76 | 77 | captureCodecToCaptureDecoding :: CaptureCodec a -> CaptureDecoding a 78 | captureCodecToCaptureDecoding (CaptureCodec _ dec) = CaptureDecoding dec 79 | 80 | showReadCaptureCodec :: (Show a, Read a) => CaptureCodec a 81 | showReadCaptureCodec = CaptureCodec (T.pack . show) (readMaybe . T.unpack) 82 | 83 | data BodyEncoding a = BodyEncoding 84 | { bodyEncodingNames :: NonEmpty N.MediaType 85 | , bodyEncodingFunction :: a -> LBS.ByteString 86 | } 87 | 88 | class HasBodyEncoding bodyStrategy where 89 | bodyEncoding :: bodyStrategy a -> BodyEncoding a 90 | 91 | instance HasBodyEncoding BodyEncoding where 92 | bodyEncoding = id 93 | 94 | data BodyDecoding a = BodyDecoding 95 | { bodyDecodingNames :: NonEmpty N.MediaType 96 | , bodyDecodingFunction :: LBS.ByteString -> Either T.Text a 97 | } 98 | 99 | class HasBodyDecoding bodyStrategy where 100 | bodyDecoding :: bodyStrategy a -> BodyDecoding a 101 | 102 | instance HasBodyDecoding BodyDecoding where 103 | bodyDecoding = id 104 | 105 | data BodyCodec a = BodyCodec 106 | { bodyCodecNames :: NonEmpty N.MediaType 107 | , bodyCodecEncode :: a -> LBS.ByteString 108 | , bodyCodecDecode :: LBS.ByteString -> Either T.Text a 109 | } 110 | 111 | class HasBodyCodec bodyStrategy where 112 | bodyCodec :: bodyStrategy a -> BodyCodec a 113 | 114 | instance HasBodyEncoding BodyCodec where 115 | bodyEncoding = bodyCodecToBodyEncoding 116 | 117 | instance HasBodyDecoding BodyCodec where 118 | bodyDecoding = bodyCodecToBodyDecoding 119 | 120 | instance HasBodyCodec BodyCodec where 121 | bodyCodec = id 122 | 123 | bodyCodecToBodyEncoding :: BodyCodec a -> BodyEncoding a 124 | bodyCodecToBodyEncoding (BodyCodec names enc _) = BodyEncoding names enc 125 | 126 | bodyCodecToBodyDecoding :: BodyCodec a -> BodyDecoding a 127 | bodyCodecToBodyDecoding (BodyCodec names _ dec) = BodyDecoding names dec 128 | 129 | showReadBodyCodec :: (Show a, Read a) => BodyCodec a 130 | showReadBodyCodec = BodyCodec 131 | (pure "text/haskell") 132 | (LBC.pack . show) 133 | (first T.pack . readEither . LBC.unpack) 134 | 135 | jsonCaptureCodec :: (FromJSON a, ToJSON a) => CaptureCodec a 136 | jsonCaptureCodec = CaptureCodec (T.decodeUtf8 . LBC.toStrict . A.encode) (A.decodeStrict . T.encodeUtf8) 137 | 138 | jsonBodyCodec :: (FromJSON a, ToJSON a) => BodyCodec a 139 | jsonBodyCodec = BodyCodec 140 | (pure "application/json; charset=utf-8") 141 | A.encode 142 | (first T.pack . A.eitherDecode) 143 | -------------------------------------------------------------------------------- /trasa/src/Trasa/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE DeriveFunctor #-} 12 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 13 | 14 | module Trasa.Core 15 | ( 16 | -- * Types 17 | Bodiedness(..) 18 | , Content(..) 19 | , Payload(..) 20 | , Router 21 | -- ** Existential 22 | , Prepared(..) 23 | , PreparedUrl(..) 24 | , Concealed(..) 25 | , Constructed(..) 26 | , conceal 27 | , concealedToPrepared 28 | , mapConstructed 29 | -- * Request Types 30 | -- ** Method 31 | , Method 32 | , encodeMethod 33 | , decodeMethod 34 | -- ** Queries 35 | , QueryString(..) 36 | , encodeQuery 37 | , decodeQuery 38 | -- ** Url 39 | , Url(..) 40 | , encodeUrl 41 | , decodeUrl 42 | , encodeUrlPieces 43 | -- ** Errors 44 | , TrasaErr(..) 45 | , status 46 | -- * Using Routes 47 | , prepareWith 48 | , prepareUrlWith 49 | , linkWith 50 | , linkUrlWith 51 | , dispatchWith 52 | , parseWith 53 | , payloadWith 54 | , requestWith 55 | , routerWith 56 | -- * Defining Routes 57 | -- ** Path 58 | , Path(..) 59 | , match 60 | , capture 61 | , end 62 | , (./) 63 | , mapPath 64 | , appendPath 65 | -- ** Query 66 | , Param(..) 67 | , Query(..) 68 | , Parameter(..) 69 | , Rec(..) 70 | , demoteParameter 71 | , flag 72 | , required 73 | , optional 74 | , list 75 | , qend 76 | , (.&) 77 | , mapQuery 78 | -- ** Request Body 79 | , RequestBody(..) 80 | , body 81 | , bodyless 82 | , encodeRequestBody 83 | , decodeRequestBody 84 | , mapRequestBody 85 | -- ** Response Body 86 | , ResponseBody(..) 87 | , resp 88 | , encodeResponseBody 89 | , decodeResponseBody 90 | , mapResponseBody 91 | -- ** Many 92 | , Many(..) 93 | , one 94 | , mapMany 95 | -- ** Meta 96 | , Meta(..) 97 | , MetaBuilder 98 | , metaBuilderToMetaCodec 99 | , MetaCodec 100 | , MetaClient 101 | , metaCodecToMetaClient 102 | , MetaServer 103 | , metaCodecToMetaServer 104 | , mapMetaPath 105 | , mapMetaQuery 106 | , mapMetaRequestBody 107 | , mapMetaResponseBody 108 | , mapMeta 109 | -- * Codecs 110 | , CaptureEncoding(..) 111 | , HasCaptureEncoding(..) 112 | , CaptureDecoding(..) 113 | , HasCaptureDecoding(..) 114 | , CaptureCodec(..) 115 | , HasCaptureCodec(..) 116 | , BodyEncoding(..) 117 | , HasBodyEncoding(..) 118 | , BodyDecoding(..) 119 | , HasBodyDecoding(..) 120 | , BodyCodec(..) 121 | , HasBodyCodec(..) 122 | -- ** Converting Codecs 123 | , captureCodecToCaptureEncoding 124 | , captureCodecToCaptureDecoding 125 | , bodyCodecToBodyEncoding 126 | , bodyCodecToBodyDecoding 127 | -- ** Type Class based Codecs 128 | , showReadCaptureCodec 129 | , showReadBodyCodec 130 | -- * Argument Currying 131 | , ParamBase 132 | , Arguments 133 | , UrlPieces 134 | , handler 135 | -- * Helpers 136 | , prettyRouter 137 | , generateAllRoutes 138 | ) where 139 | 140 | import Control.Applicative (liftA2) 141 | import Control.Monad (unless) 142 | import Data.Bifunctor (first,bimap) 143 | import Data.Foldable (toList) 144 | import Data.Functor.Identity (Identity(..)) 145 | import Data.HashMap.Strict (HashMap) 146 | import Data.Kind (Type) 147 | import Data.List.NonEmpty (NonEmpty) 148 | import Data.Maybe (mapMaybe,listToMaybe,isJust,fromMaybe) 149 | import Language.Haskell.TH.Syntax (Name,Q,Dec,TyVarBndr(..)) 150 | import Topaz.Types (Rec(..), type (++)) 151 | import qualified Data.ByteString.Lazy as LBS 152 | import qualified Data.HashMap.Strict as HM 153 | import qualified Data.List as L 154 | import qualified Data.List.NonEmpty as NE 155 | import qualified Data.Semigroup as SG 156 | import qualified Data.Text as T 157 | import qualified Data.Text.Encoding as T 158 | import qualified Language.Haskell.TH.Datatype as THD 159 | import qualified Language.Haskell.TH.Syntax as TH 160 | import qualified Network.HTTP.Media.Accept as N 161 | import qualified Network.HTTP.Media.MediaType as N 162 | import qualified Network.HTTP.Types.Status as N 163 | import qualified Topaz.Rec as Topaz 164 | 165 | import Trasa.Method 166 | import Trasa.Url 167 | import Trasa.Error 168 | import Trasa.Codec 169 | 170 | -- $setup 171 | -- >>> :set -XTypeInType 172 | 173 | newtype Many f a = Many { getMany :: NonEmpty (f a) } 174 | deriving (Functor) 175 | 176 | instance Applicative f => Applicative (Many f) where 177 | pure = Many . pure . pure 178 | Many mf <*> Many mx = Many $ liftA2 (<*>) mf mx 179 | 180 | one :: f a -> Many f a 181 | one = Many . pure 182 | 183 | mapMany :: (forall x. f x -> g x) -> Many f a -> Many g a 184 | mapMany eta (Many m) = Many (fmap eta m) 185 | 186 | -- | the type of the HTTP message body (json, text, etc) 187 | data Bodiedness = forall a. Body a | Bodyless 188 | 189 | data RequestBody :: (Type -> Type) -> Bodiedness -> Type where 190 | RequestBodyPresent :: !(f a) -> RequestBody f ('Body a) 191 | RequestBodyAbsent :: RequestBody f 'Bodyless 192 | 193 | body :: rqf req -> RequestBody rqf ('Body req) 194 | body = RequestBodyPresent 195 | 196 | bodyless :: RequestBody rqf 'Bodyless 197 | bodyless = RequestBodyAbsent 198 | 199 | mapRequestBody :: (forall x. rqf x -> rqf' x) -> RequestBody rqf request -> RequestBody rqf' request 200 | mapRequestBody _ RequestBodyAbsent = RequestBodyAbsent 201 | mapRequestBody f (RequestBodyPresent reqBod) = RequestBodyPresent (f reqBod) 202 | 203 | newtype ResponseBody rpf response = ResponseBody { getResponseBody :: rpf response } 204 | 205 | resp :: rpf resp -> ResponseBody rpf resp 206 | resp = ResponseBody 207 | 208 | mapResponseBody :: (forall x. rpf x -> rpf' x) -> ResponseBody rpf request -> ResponseBody rpf' request 209 | mapResponseBody f (ResponseBody resBod) = ResponseBody (f resBod) 210 | 211 | data Path :: (Type -> Type) -> [Type] -> Type where 212 | PathNil :: Path cap '[] 213 | PathConsCapture :: !(cap a) -> !(Path cap as) -> Path cap (a ': as) 214 | PathConsMatch :: !T.Text -> !(Path cap as) -> Path cap as 215 | 216 | -- | flipped ($), useful for constructing routes. e.g. 217 | -- > match "add" ./ capture int ./ capture int ./ end 218 | infixr 7 ./ 219 | (./) :: (a -> b) -> a -> b 220 | (./) f a = f a 221 | 222 | match :: T.Text -> Path cpf caps -> Path cpf caps 223 | match = PathConsMatch 224 | 225 | capture :: cpf cap -> Path cpf caps -> Path cpf (cap ': caps) 226 | capture = PathConsCapture 227 | 228 | end :: Path cpf '[] 229 | end = PathNil 230 | 231 | mapPath :: (forall x. cf x -> cf' x) -> Path cf ps -> Path cf' ps 232 | mapPath _ PathNil = PathNil 233 | mapPath f (PathConsMatch s pnext) = PathConsMatch s (mapPath f pnext) 234 | mapPath f (PathConsCapture c pnext) = PathConsCapture (f c) (mapPath f pnext) 235 | 236 | appendPath :: Path f as -> Path f bs -> Path f (as ++ bs) 237 | appendPath PathNil bs = bs 238 | appendPath (PathConsMatch a as) bs = PathConsMatch a (appendPath as bs) 239 | appendPath (PathConsCapture cas as) bs = PathConsCapture cas (appendPath as bs) 240 | 241 | data Param 242 | = Flag 243 | | forall a. Required a 244 | | forall a. Optional a 245 | | forall a. List a 246 | 247 | data Parameter :: Param -> Type where 248 | ParameterFlag :: !Bool -> Parameter 'Flag 249 | ParameterRequired :: !a -> Parameter ('Required a) 250 | ParameterOptional :: !(Maybe a) -> Parameter ('Optional a) 251 | ParameterList :: ![a] -> Parameter ('List a) 252 | 253 | data Query :: (Type -> Type) -> Param -> Type where 254 | QueryFlag :: !T.Text -> Query cap 'Flag 255 | QueryRequired :: !T.Text -> !(cap a) -> Query cap ('Required a) 256 | QueryOptional :: !T.Text -> !(cap a) -> Query cap ('Optional a) 257 | QueryList :: !T.Text -> !(cap a) -> Query cap ('List a) 258 | 259 | flag :: T.Text -> Query cpf 'Flag 260 | flag = QueryFlag 261 | 262 | required :: T.Text -> cpf query -> Query cpf ('Required query) 263 | required = QueryRequired 264 | 265 | optional :: T.Text -> cpf query -> Query cpf ('Optional query) 266 | optional = QueryOptional 267 | 268 | list :: T.Text -> cpf query -> Query cpf ('List query) 269 | list = QueryList 270 | 271 | qend :: Rec (Query qpf) '[] 272 | qend = RecNil 273 | 274 | infixr 7 .& 275 | 276 | (.&) :: Query qpf q -> Rec (Query qpf) qs -> Rec (Query qpf) (q ': qs) 277 | (.&) = RecCons 278 | 279 | mapQuery :: (forall x. f x -> g x) -> Rec (Query f) qs -> Rec (Query g) qs 280 | mapQuery eta = Topaz.map $ \case 281 | QueryFlag key -> QueryFlag key 282 | QueryRequired key query -> QueryRequired key (eta query) 283 | QueryOptional key query -> QueryOptional key (eta query) 284 | QueryList key query -> QueryList key (eta query) 285 | 286 | data Meta capCodec qryCodec reqCodec respCodec caps qrys req resp = Meta 287 | { metaPath :: !(Path capCodec caps) 288 | , metaQuery :: !(Rec (Query qryCodec) qrys) 289 | , metaRequestBody :: !(RequestBody reqCodec req) 290 | , metaResponseBody :: !(ResponseBody respCodec resp) 291 | , metaMethod :: !Method 292 | } 293 | 294 | mapMetaPath 295 | :: (forall x. cf x -> cg x) 296 | -> Meta cf qryCodec reqCodec respCodec caps qrys req resp 297 | -> Meta cg qryCodec reqCodec respCodec caps qrys req resp 298 | mapMetaPath eta m = m { metaPath = mapPath eta (metaPath m) } 299 | 300 | mapMetaQuery 301 | :: (forall x. qf x -> qg x) 302 | -> Meta capCodec qf reqCodec respCodec caps qrys req resp 303 | -> Meta capCodec qg reqCodec respCodec caps qrys req resp 304 | mapMetaQuery eta m = m { metaQuery = mapQuery eta (metaQuery m) } 305 | 306 | mapMetaRequestBody 307 | :: (forall x. rf x -> rg x) 308 | -> Meta capCodec qryCodec rf respCodec caps qrys req resp 309 | -> Meta capCodec qryCodec rg respCodec caps qrys req resp 310 | mapMetaRequestBody eta m = m { metaRequestBody = mapRequestBody eta (metaRequestBody m) } 311 | 312 | mapMetaResponseBody 313 | :: (forall x. rf x -> rg x) 314 | -> Meta capCodec qryCodec reqCodec rf caps qrys req resp 315 | -> Meta capCodec qryCodec reqCodec rg caps qrys req resp 316 | mapMetaResponseBody eta m = m { metaResponseBody = mapResponseBody eta (metaResponseBody m)} 317 | 318 | mapMeta 319 | :: (forall x. capCodec1 x -> capCodec2 x) 320 | -> (forall x. qryCodec1 x -> qryCodec2 x) 321 | -> (forall x. reqCodec1 x -> reqCodec2 x) 322 | -> (forall x. respCodec1 x -> respCodec2 x) 323 | -> Meta capCodec1 qryCodec1 reqCodec1 respCodec1 caps qrys req resp 324 | -> Meta capCodec2 qryCodec2 reqCodec2 respCodec2 caps qrys req resp 325 | mapMeta mapCaps mapQrys mapReq mapResp (Meta caps qrys req res method) = Meta 326 | (mapPath mapCaps caps) 327 | (mapQuery mapQrys qrys) 328 | (mapRequestBody mapReq req) 329 | (mapResponseBody mapResp res) 330 | method 331 | 332 | type MetaBuilder = Meta CaptureCodec CaptureCodec BodyCodec BodyCodec 333 | 334 | -- | This function is a more general way to transform 'MetaBuilder' into 'MetaCodec'. 335 | -- 336 | -- It wraps the req and resp codecs in Many. 337 | metaBuilderToMetaCodec 338 | :: Meta capCodec qryCodec reqCodec respCodec caps qrys req resp 339 | -> Meta capCodec qryCodec (Many reqCodec) (Many respCodec) caps qrys req resp 340 | metaBuilderToMetaCodec (Meta path query reqBody respBody method) = Meta 341 | path 342 | query 343 | (mapRequestBody one reqBody) 344 | (mapResponseBody one respBody) 345 | method 346 | 347 | type MetaCodec = Meta CaptureCodec CaptureCodec (Many BodyCodec) (Many BodyCodec) 348 | 349 | type MetaClient = Meta CaptureEncoding CaptureEncoding (Many BodyEncoding) (Many BodyDecoding) 350 | 351 | metaCodecToMetaClient :: MetaCodec caps qrys req resp -> MetaClient caps qrys req resp 352 | metaCodecToMetaClient = mapMeta captureEncoding captureEncoding (mapMany bodyEncoding) (mapMany bodyDecoding) 353 | 354 | type MetaServer = Meta CaptureDecoding CaptureDecoding (Many BodyDecoding) (Many BodyEncoding) 355 | 356 | metaCodecToMetaServer :: MetaCodec caps qrys req resp -> MetaServer caps qrys req resp 357 | metaCodecToMetaServer = mapMeta captureDecoding captureDecoding (mapMany bodyDecoding) (mapMany bodyEncoding) 358 | 359 | -- | Generate a @Url@ for use in hyperlinks. 360 | linkWith 361 | :: forall route response reqCodec respCodec 362 | . (forall caps qrys req resp. route caps qrys req resp -> Meta CaptureEncoding CaptureEncoding reqCodec respCodec caps qrys req resp) 363 | -> Prepared route response 364 | -- ^ The route to encode 365 | -> Url 366 | linkWith toMeta (Prepared route captures querys _) = 367 | encodeUrlPieces (metaPath m) (metaQuery m) captures querys 368 | where m = toMeta route 369 | 370 | linkUrlWith 371 | :: forall route reqCodec respCodec 372 | . (forall caps qrys req resp. route caps qrys req resp -> Meta CaptureEncoding CaptureEncoding reqCodec respCodec caps qrys req resp) 373 | -> PreparedUrl route 374 | -- ^ The route to encode 375 | -> Url 376 | linkUrlWith toMeta (PreparedUrl route captures querys) = 377 | encodeUrlPieces (metaPath m) (metaQuery m) captures querys 378 | where m = toMeta route 379 | 380 | data Payload = Payload 381 | { payloadUrl :: !Url 382 | , payloadContent :: !(Maybe Content) 383 | , payloadAccepts :: !(NonEmpty N.MediaType) 384 | } 385 | 386 | -- | Only useful for library authors 387 | payloadWith 388 | :: forall route response 389 | . (forall caps qrys req resp. route caps qrys req resp -> MetaClient caps qrys req resp) 390 | -> Prepared route response 391 | -- ^ The route to be payload encoded 392 | -> Payload 393 | payloadWith toMeta p@(Prepared route _ _ reqBody) = 394 | Payload url content accepts 395 | where 396 | url = linkWith toMeta p 397 | m = toMeta route 398 | content = encodeRequestBody (metaRequestBody m) reqBody 399 | ResponseBody (Many decodings) = metaResponseBody m 400 | accepts = bodyDecodingNames =<< decodings 401 | 402 | -- Only useful to implement packages like 'trasa-client' 403 | requestWith 404 | :: Functor m 405 | => (forall caps qrys req resp. route caps qrys req resp -> MetaClient caps qrys req resp) 406 | -> (Method -> Url -> Maybe Content -> NonEmpty N.MediaType -> m (Either TrasaErr Content)) 407 | -- ^ method, url, content, accepts -> response 408 | -> Prepared route response 409 | -> m (Either TrasaErr response) 410 | requestWith toMeta run (Prepared route captures querys reqBody) = 411 | let m = toMeta route 412 | method = metaMethod m 413 | url = encodeUrlPieces (metaPath m) (metaQuery m) captures querys 414 | content = encodeRequestBody (metaRequestBody m) reqBody 415 | respBodyDecs@(ResponseBody (Many decodings)) = metaResponseBody m 416 | accepts = bodyDecodingNames =<< decodings 417 | in fmap (\c -> c >>= decodeResponseBody respBodyDecs) (run method url content accepts) 418 | 419 | encodeRequestBody :: RequestBody (Many BodyEncoding) request -> RequestBody Identity request -> Maybe Content 420 | encodeRequestBody RequestBodyAbsent RequestBodyAbsent = Nothing 421 | encodeRequestBody (RequestBodyPresent (Many encodings)) (RequestBodyPresent (Identity rq)) = 422 | case NE.head encodings of 423 | BodyEncoding names encoding -> Just (Content (Just $NE.head names) (encoding rq)) 424 | 425 | decodeRequestBody 426 | :: RequestBody (Many BodyDecoding) req 427 | -> Maybe Content 428 | -> Either TrasaErr (RequestBody Identity req) 429 | decodeRequestBody reqDec mcontent = case reqDec of 430 | RequestBodyPresent decs -> case mcontent of 431 | Nothing -> wrongBody 432 | Just (Content media bod) -> case media of 433 | Nothing -> let nel = getMany decs in go (toList nel) (NE.head $ bodyDecodingNames $ NE.head nel) bod 434 | Just m -> go (toList (getMany decs)) m bod 435 | RequestBodyAbsent -> case mcontent of 436 | Nothing -> Right RequestBodyAbsent 437 | Just (Content _ bod) -> if LBS.null bod 438 | then Right RequestBodyAbsent 439 | else wrongBody 440 | where 441 | wrongBody = Left (status N.status415) 442 | go :: [BodyDecoding a] -> N.MediaType -> LBS.ByteString -> Either TrasaErr (RequestBody Identity ('Body a)) 443 | go [] _ _ = Left (status N.status415) 444 | go (BodyDecoding medias dec:decs) media bod = case any (flip mediaMatches media) medias of 445 | True -> bimap (TrasaErr N.status415 . LBS.fromStrict . T.encodeUtf8) 446 | (RequestBodyPresent . Identity) 447 | (dec bod) 448 | False -> go decs media bod 449 | 450 | mediaMatches :: N.MediaType -> N.MediaType -> Bool 451 | mediaMatches _ "*/*" = True 452 | mediaMatches "*/*" _ = True 453 | mediaMatches x y = N.matches x y 454 | 455 | encodeResponseBody 456 | :: forall response 457 | . [N.MediaType] 458 | -> ResponseBody (Many BodyEncoding) response 459 | -> response 460 | -> Either TrasaErr Content 461 | encodeResponseBody medias (ResponseBody encs) res = go (toList (getMany encs)) 462 | where 463 | go :: [BodyEncoding response] -> Either TrasaErr Content 464 | go [] = Left (status N.status406) 465 | go (BodyEncoding accepts e:es) = case acceptable (toList accepts) medias of 466 | Just typ -> Right (Content (Just typ) (e res)) 467 | Nothing -> go es 468 | acceptable :: [N.MediaType] -> [N.MediaType] -> Maybe N.MediaType 469 | acceptable [] _ = Nothing 470 | acceptable (a:as) ms = case any (N.matches a) ms of 471 | True -> Just a 472 | False -> acceptable as ms 473 | 474 | decodeResponseBody :: ResponseBody (Many BodyDecoding) response -> Content -> Either TrasaErr response 475 | decodeResponseBody (ResponseBody (Many decodings)) (Content mname content) = go (toList decodings) 476 | where 477 | name = fromMaybe (NE.head $ bodyDecodingNames $ NE.head decodings) mname 478 | go :: [BodyDecoding response] -> Either TrasaErr response 479 | go [] = Left (status N.status415) 480 | go (BodyDecoding names dec:decs) = case any (N.matches name) names of 481 | True -> first (TrasaErr N.status400 . LBS.fromStrict . T.encodeUtf8) (dec content) 482 | False -> go decs 483 | 484 | encodeUrlPieces 485 | :: Path CaptureEncoding captures 486 | -> Rec (Query CaptureEncoding) querys 487 | -> Rec Identity captures 488 | -> Rec Parameter querys 489 | -> Url 490 | encodeUrlPieces pathEncoding queryEncoding path querys = 491 | Url (encodePath pathEncoding path) (QueryString (encodeQueries queryEncoding querys)) 492 | where 493 | encodePath 494 | :: forall caps 495 | . Path CaptureEncoding caps 496 | -> Rec Identity caps 497 | -> [T.Text] 498 | encodePath PathNil RecNil = [] 499 | encodePath (PathConsMatch str ps) xs = str : encodePath ps xs 500 | encodePath (PathConsCapture (CaptureEncoding enc) ps) (Identity x `RecCons` xs) = enc x : encodePath ps xs 501 | encodeQueries 502 | :: forall qrys 503 | . Rec (Query CaptureEncoding) qrys 504 | -> Rec Parameter qrys 505 | -> HM.HashMap T.Text QueryParam 506 | encodeQueries RecNil RecNil = HM.empty 507 | encodeQueries (QueryFlag key `RecCons` encs) (ParameterFlag on `RecCons` qs) = 508 | if on then HM.insert key QueryParamFlag rest else rest 509 | where rest = encodeQueries encs qs 510 | encodeQueries (QueryRequired key (CaptureEncoding enc) `RecCons` encs) (ParameterRequired val `RecCons` qs) = 511 | HM.insert key (QueryParamSingle (enc val)) rest 512 | where rest = encodeQueries encs qs 513 | encodeQueries (QueryOptional key (CaptureEncoding enc) `RecCons` encs) (ParameterOptional mval `RecCons` qs) = 514 | maybe rest (\val -> HM.insert key (QueryParamSingle (enc val)) rest) mval 515 | where rest = encodeQueries encs qs 516 | encodeQueries (QueryList key (CaptureEncoding enc) `RecCons` encs) (ParameterList vals `RecCons` qs) = 517 | HM.insert key (QueryParamList (fmap enc vals)) (encodeQueries encs qs) 518 | 519 | -- | Only useful to implement packages like 'trasa-server' 520 | dispatchWith 521 | :: forall route m 522 | . Applicative m 523 | => (forall caps qrys req resp. route caps qrys req resp -> MetaServer caps qrys req resp) 524 | -> (forall caps qrys req resp. route caps qrys req resp -> Rec Identity caps -> Rec Parameter qrys -> RequestBody Identity req -> m resp) 525 | -> Router route -- ^ Router 526 | -> Method -- ^ Method 527 | -> [N.MediaType] -- ^ Accept headers 528 | -> Url -- ^ Everything after the authority 529 | -> Maybe Content -- ^ Content type and request body 530 | -> m (Either TrasaErr Content) -- ^ Encoded response 531 | dispatchWith toMeta makeResponse madeRouter method accepts url mcontent = 532 | case parseWith toMeta madeRouter method url mcontent of 533 | Left err -> pure (Left err) 534 | Right (Concealed route path querys reqBody) -> 535 | encodeResponseBody accepts (metaResponseBody (toMeta route)) <$> 536 | makeResponse route path querys reqBody 537 | 538 | -- | Build a router from all the possible routes, and methods to turn routes into needed metadata 539 | routerWith 540 | :: forall route qryCodec reqCodec respCodec 541 | . (forall caps qrys req resp. route caps qrys req resp -> Meta CaptureDecoding qryCodec reqCodec respCodec caps qrys req resp) 542 | -> [Constructed route] 543 | -> Router route 544 | routerWith toMeta = Router . foldMap buildRouter 545 | where 546 | buildRouter :: Constructed route -> IxedRouter route 'Z 547 | buildRouter (Constructed route) = singletonIxedRouter route (metaMethod m) (metaPath m) 548 | where m = toMeta route 549 | 550 | 551 | -- | Parses the path, the querystring, and the request body. 552 | parseWith 553 | :: forall route capCodec respCodec 554 | . (forall caps qrys req resp. route caps qrys req resp -> Meta capCodec CaptureDecoding (Many BodyDecoding) respCodec caps qrys req resp) 555 | -> Router route -- ^ Router 556 | -> Method -- ^ Request Method 557 | -> Url -- ^ Everything after the authority 558 | -> Maybe Content -- ^ Request content type and body 559 | -> Either TrasaErr (Concealed route) 560 | parseWith toMeta madeRouter method (Url encodedPath encodedQuery) mcontent = do 561 | Pathed route captures <- parsePathWith madeRouter method encodedPath 562 | let m = toMeta route 563 | querys <- parseQueryWith (metaQuery m) encodedQuery 564 | reqBody <- decodeRequestBody (metaRequestBody m) mcontent 565 | pure (Concealed route captures querys reqBody) 566 | 567 | -- | Parses only the path. 568 | parsePathWith :: forall route. 569 | Router route 570 | -> Method -- ^ Method 571 | -> [T.Text] -- ^ Path Pieces 572 | -> Either TrasaErr (Pathed route) 573 | parsePathWith (Router r0) method pieces0 = go VecNil pieces0 r0 574 | where 575 | go :: forall n. 576 | Vec n T.Text -- captures being accumulated 577 | -> [T.Text] -- remaining pieces 578 | -> IxedRouter route n -- router fragment 579 | -> Either TrasaErr (Pathed route) 580 | go captures ps (IxedRouter matches mcapture responders) = case ps of 581 | [] -> case HM.lookup (encodeMethod method) responders of 582 | Nothing -> Left (status N.status405) 583 | Just respondersAtMethod -> fromMaybe (Left (status N.status400)) . listToMaybe $ 584 | ( mapMaybe 585 | (\(IxedResponder route capDecs) -> 586 | fmap (\x -> (Right (Pathed route x))) (decodeCaptureVector capDecs captures) 587 | ) 588 | respondersAtMethod 589 | ) 590 | (p:psNext) -> 591 | let res1 = maybe [] (:[]) $ fmap (go captures psNext) (HM.lookup p matches) 592 | -- Since this uses snocVec to build up the captures, 593 | -- this algorithm's complexity includes a term that is 594 | -- O(n^2) in the number of captures. However, most routes 595 | -- that I deal with have one or two captures. Occassionally, 596 | -- I'll get one with four or five, but this happens 597 | -- so infrequently that I'm not concerned about this. 598 | res2 = maybe [] (:[]) $ fmap (go (snocVec p captures) psNext) mcapture 599 | in fromMaybe (Left (status N.status400)) . listToMaybe $ res1 ++ res2 600 | 601 | parseQueryWith :: Rec (Query CaptureDecoding) querys -> QueryString -> Either TrasaErr (Rec Parameter querys) 602 | parseQueryWith decoding (QueryString querys) = Topaz.traverse param decoding 603 | where 604 | param :: forall qry. Query CaptureDecoding qry -> Either TrasaErr (Parameter qry) 605 | param = \case 606 | QueryFlag key -> Right (ParameterFlag (HM.member key querys)) 607 | QueryRequired key (CaptureDecoding dec) -> case HM.lookup key querys of 608 | Nothing -> Left (TrasaErr N.status400 "required query param is absent") 609 | Just query -> case query of 610 | QueryParamFlag -> Left (TrasaErr N.status400 "query flag given when key-value expected") 611 | QueryParamSingle txt -> case dec txt of 612 | Just dtxt -> Right (ParameterRequired dtxt) 613 | Nothing -> Left (TrasaErr N.status400 "failed to decode required query parameter") 614 | QueryParamList _ -> Left (TrasaErr N.status400 "query param list given when key-value expected") 615 | QueryOptional key (CaptureDecoding dec) -> case HM.lookup key querys of 616 | Nothing -> Right (ParameterOptional Nothing) 617 | Just query -> case query of 618 | QueryParamFlag -> Left (TrasaErr N.status400 "query flag given when key-value expected") 619 | QueryParamSingle txt -> Right (ParameterOptional (dec txt)) 620 | QueryParamList _ -> Left (TrasaErr N.status400 "query param list given when key-value expected") 621 | QueryList key (CaptureDecoding dec) -> case HM.lookup key querys of 622 | Nothing -> Right (ParameterList []) 623 | Just query -> case query of 624 | QueryParamFlag -> Left (TrasaErr N.status400 "query flag given when list expected") 625 | QueryParamSingle txt -> Right (ParameterList (maybe [] (:[]) (dec txt))) 626 | QueryParamList txts -> Right (ParameterList (mapMaybe dec txts)) 627 | 628 | decodeCaptureVector :: 629 | IxedRec CaptureDecoding n xs 630 | -> Vec n T.Text 631 | -> Maybe (Rec Identity xs) 632 | decodeCaptureVector IxedRecNil VecNil = Just RecNil 633 | decodeCaptureVector (IxedRecCons (CaptureDecoding decode) rnext) (VecCons piece vnext) = do 634 | val <- decode piece 635 | vals <- decodeCaptureVector rnext vnext 636 | pure (Identity val `RecCons` vals) 637 | 638 | type family ParamBase (param :: Param) :: Type where 639 | ParamBase 'Flag = Bool 640 | ParamBase ('Required a) = a 641 | ParamBase ('Optional a) = Maybe a 642 | ParamBase ('List a) = [a] 643 | 644 | demoteParameter :: Parameter param -> ParamBase param 645 | demoteParameter = \case 646 | ParameterFlag b -> b 647 | ParameterRequired v -> v 648 | ParameterOptional m -> m 649 | ParameterList l -> l 650 | 651 | -- | A closed, total type family provided as a convenience to end users. 652 | -- Other function is this library take advantage of 'Arguments' to allow 653 | -- end users use normal function application. Without this, users would 654 | -- need to write out 'Record' and 'RequestBody' values by hand, which 655 | -- is tedious. 656 | -- 657 | -- >>> :kind! Arguments '[Int,Bool] '[Flag,Optional Double,List Int] 'Bodyless Double 658 | -- Arguments '[Int,Bool] '[Flag,Optional Double,List Int] 'Bodyless Double :: * 659 | -- = Int -> Bool -> Bool -> Maybe Double -> [Int] -> Double 660 | type family Arguments (pieces :: [Type]) (querys :: [Param]) (body :: Bodiedness) (result :: Type) :: Type where 661 | Arguments '[] '[] ('Body b) r = b -> r 662 | Arguments '[] '[] 'Bodyless r = r 663 | Arguments '[] (q ': qs) r b = ParamBase q -> Arguments '[] qs r b 664 | Arguments (c ': cs) qs b r = c -> Arguments cs qs b r 665 | 666 | type family UrlPieces (pieces :: [Type]) (querys :: [Param]) (result :: Type) :: Type where 667 | UrlPieces '[] '[] r = r 668 | UrlPieces '[] (q ': qs) r = ParamBase q -> UrlPieces '[] qs r 669 | UrlPieces (c ': cs) qs r = c -> UrlPieces cs qs r 670 | 671 | -- | Used my users to define a function called prepare, see tutorial 672 | prepareWith 673 | :: (forall caps qrys req resp. route caps qrys req resp -> Meta capCodec qryCodec reqCodec respCodec caps qrys req resp) 674 | -> route captures query request response 675 | -- ^ The route to prepare 676 | -> Arguments captures query request (Prepared route response) 677 | prepareWith toMeta route = 678 | prepareExplicit route (metaPath m) (metaQuery m) (metaRequestBody m) 679 | where m = toMeta route 680 | 681 | prepareExplicit :: forall route captures queries request response rqf pf qf. 682 | route captures queries request response 683 | -> Path pf captures 684 | -> Rec (Query qf) queries 685 | -> RequestBody rqf request 686 | -> Arguments captures queries request (Prepared route response) 687 | prepareExplicit route = go (Prepared route) 688 | where 689 | -- Adopted from: https://www.reddit.com/r/haskell/comments/67l9so/currying_a_typelevel_list/dgrghxz/ 690 | go :: forall caps qrys z. 691 | (Rec Identity caps -> Rec Parameter qrys -> RequestBody Identity request -> z) 692 | -> Path pf caps 693 | -> Rec (Query qf) qrys 694 | -> RequestBody rqf request 695 | -> Arguments caps qrys request z 696 | go k PathNil RecNil RequestBodyAbsent = 697 | k RecNil RecNil RequestBodyAbsent 698 | go k PathNil RecNil (RequestBodyPresent _) = 699 | \reqBod -> k RecNil RecNil (RequestBodyPresent (Identity reqBod)) 700 | go k PathNil (q `RecCons` qs) b = 701 | \qt -> go (\caps querys reqBody -> k caps (parameter q qt `RecCons` querys) reqBody) PathNil qs b 702 | go k (PathConsMatch _ pnext) qs b = 703 | go k pnext qs b 704 | go k (PathConsCapture _ pnext) qs b = 705 | \c -> go (\caps querys reqBod -> k (Identity c `RecCons` caps) querys reqBod) pnext qs b 706 | parameter :: forall param. Query qf param -> ParamBase param -> Parameter param 707 | parameter (QueryFlag _) b = ParameterFlag b 708 | parameter (QueryRequired _ _) v = ParameterRequired v 709 | parameter (QueryOptional _ _) m = ParameterOptional m 710 | parameter (QueryList _ _) l = ParameterList l 711 | 712 | prepareUrlWith 713 | :: (forall caps qrys req resp. route caps qrys req resp -> Meta capCodec qryCodec reqCodec respCodec caps qrys req resp) 714 | -> route captures query request response 715 | -- ^ The route to prepare 716 | -> UrlPieces captures query (PreparedUrl route) 717 | prepareUrlWith toMeta route = 718 | prepareUrlExplicit route (metaPath m) (metaQuery m) 719 | where m = toMeta route 720 | 721 | prepareUrlExplicit :: forall route captures queries request response pf qf. 722 | route captures queries request response 723 | -> Path pf captures 724 | -> Rec (Query qf) queries 725 | -> UrlPieces captures queries (PreparedUrl route) 726 | prepareUrlExplicit route = go (PreparedUrl route) 727 | where 728 | -- Adopted from: https://www.reddit.com/r/haskell/comments/67l9so/currying_a_typelevel_list/dgrghxz/ 729 | go :: forall caps qrys z. 730 | (Rec Identity caps -> Rec Parameter qrys -> z) 731 | -> Path pf caps 732 | -> Rec (Query qf) qrys 733 | -> UrlPieces caps qrys z 734 | go k PathNil RecNil = k RecNil RecNil 735 | go k PathNil (q `RecCons` qs) = 736 | \qt -> go (\caps querys -> k caps (parameter q qt `RecCons` querys)) PathNil qs 737 | go k (PathConsMatch _ pnext) qs = 738 | go k pnext qs 739 | go k (PathConsCapture _ pnext) qs = 740 | \c -> go (\caps querys -> k (Identity c `RecCons` caps) querys) pnext qs 741 | parameter :: forall param. Query qf param -> ParamBase param -> Parameter param 742 | parameter (QueryFlag _) b = ParameterFlag b 743 | parameter (QueryRequired _ _) v = ParameterRequired v 744 | parameter (QueryOptional _ _) m = ParameterOptional m 745 | parameter (QueryList _ _) l = ParameterList l 746 | 747 | -- | Uncurry the arguments type family 748 | handler :: forall captures querys request x. 749 | Rec Identity captures 750 | -> Rec Parameter querys 751 | -> RequestBody Identity request 752 | -> Arguments captures querys request x 753 | -> x 754 | handler = go 755 | where 756 | go :: forall caps qrys. 757 | Rec Identity caps 758 | -> Rec Parameter qrys 759 | -> RequestBody Identity request 760 | -> Arguments caps qrys request x 761 | -> x 762 | go RecNil RecNil RequestBodyAbsent f = f 763 | go RecNil RecNil (RequestBodyPresent (Identity b)) f = f b 764 | go RecNil (q `RecCons` qs) b f = go RecNil qs b (f (demoteParameter q)) 765 | go (Identity c `RecCons` cs) qs b f = go cs qs b (f c) 766 | 767 | -- | A route with all types hidden: the captures, the request body, 768 | -- and the response body. This is needed so that users can 769 | -- enumerate over all the routes. 770 | data Constructed :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Type where 771 | Constructed :: !(route captures querys request response) -> Constructed route 772 | -- I dont really like the name Constructed, but I don't want to call it 773 | -- Some or Any since these get used a lot and a conflict would be likely. 774 | -- Think, think, think. 775 | 776 | mapConstructed :: 777 | (forall caps qrys req resp. sub caps qrys req resp -> route caps qrys req resp) 778 | -> Constructed sub 779 | -> Constructed route 780 | mapConstructed f (Constructed sub) = Constructed (f sub) 781 | 782 | data Pathed :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Type where 783 | Pathed :: !(route captures querys request response) -> !(Rec Identity captures) -> Pathed route 784 | 785 | -- | Includes the route, path, query parameters, and request body. 786 | data Prepared :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Type -> Type where 787 | Prepared :: 788 | !(route captures querys request response) 789 | -> !(Rec Identity captures) 790 | -> !(Rec Parameter querys) 791 | -> !(RequestBody Identity request) 792 | -> Prepared route response 793 | 794 | -- | Includes the route, path, query parameters 795 | data PreparedUrl :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Type where 796 | PreparedUrl :: 797 | !(route captures querys request response) 798 | -> !(Rec Identity captures) 799 | -> !(Rec Parameter querys) 800 | -> PreparedUrl route 801 | 802 | -- | Only needed to implement 'parseWith'. Most users do not need this. 803 | -- If you need to create a route hierarchy to provide breadcrumbs, 804 | -- then you will need this. 805 | data Concealed :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Type where 806 | Concealed :: 807 | !(route captures querys request response) 808 | -> !(Rec Identity captures) 809 | -> !(Rec Parameter querys) 810 | -> !(RequestBody Identity request) 811 | -> Concealed route 812 | 813 | -- | Conceal the response type. 814 | conceal :: Prepared route response -> Concealed route 815 | conceal (Prepared route caps querys req) = Concealed route caps querys req 816 | 817 | concealedToPrepared 818 | :: forall route a 819 | . Concealed route 820 | -> (forall resp. Prepared route resp -> a) 821 | -> a 822 | concealedToPrepared (Concealed route caps qrys req) f = f (Prepared route caps qrys req) 823 | 824 | -- | The HTTP content type and body. 825 | data Content = Content 826 | { contentType :: !(Maybe N.MediaType) 827 | , contentData :: !LBS.ByteString 828 | } deriving (Show,Eq,Ord) 829 | 830 | -- | Only promoted version used. 831 | data Nat = S !Nat | Z 832 | 833 | newtype Router route = Router (IxedRouter route 'Z) 834 | 835 | data IxedRouter :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Nat -> Type where 836 | IxedRouter :: 837 | !(HashMap T.Text (IxedRouter route n)) 838 | -> !(Maybe (IxedRouter route ('S n))) 839 | -> !(HashMap T.Text [IxedResponder route n]) -- Should be either zero or one, more than one means that there are trivially overlapped routes 840 | -> IxedRouter route n 841 | 842 | -- | This monoid instance is provided so that we can 843 | -- conveniently use foldMap elsewhere. We do not 844 | -- provide a Monoid instance for Router like we do 845 | -- for IxedRouter. End users only have one way to create 846 | -- a router, and if they combine a Router with itself 847 | -- using mappend, it would result in Router in which all 848 | -- routes were overlapped. 849 | instance Monoid (IxedRouter route n) where 850 | mempty = IxedRouter HM.empty Nothing HM.empty 851 | mappend = (SG.<>) 852 | 853 | instance SG.Semigroup (IxedRouter route n) where 854 | (<>) = unionIxedRouter 855 | 856 | data IxedResponder :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Nat -> Type where 857 | IxedResponder :: 858 | !(route captures query request response) 859 | -> !(IxedRec CaptureDecoding n captures) 860 | -> IxedResponder route n 861 | 862 | data IxedRec :: (k -> Type) -> Nat -> [k] -> Type where 863 | IxedRecNil :: IxedRec f 'Z '[] 864 | IxedRecCons :: !(f r) -> !(IxedRec f n rs) -> IxedRec f ('S n) (r ': rs) 865 | 866 | data Vec :: Nat -> Type -> Type where 867 | VecNil :: Vec 'Z a 868 | VecCons :: !a -> !(Vec n a) -> Vec ('S n) a 869 | 870 | data IxedPath :: (Type -> Type) -> Nat -> [Type] -> Type where 871 | IxedPathNil :: IxedPath f 'Z '[] 872 | IxedPathCapture :: !(f a) -> !(IxedPath f n as) -> IxedPath f ('S n) (a ': as) 873 | IxedPathMatch :: !T.Text -> !(IxedPath f n a) -> IxedPath f n a 874 | 875 | data LenPath :: Nat -> Type where 876 | LenPathNil :: LenPath 'Z 877 | LenPathCapture :: !(LenPath n) -> LenPath ('S n) 878 | LenPathMatch :: !T.Text -> !(LenPath n) -> LenPath n 879 | 880 | -- Assumes length is in penultimate position. 881 | data HideIx :: (Nat -> k -> Type) -> k -> Type where 882 | HideIx :: !(f n a) -> HideIx f a 883 | 884 | -- toIxedRec :: Rec f xs -> HideIx (IxedRec f) xs 885 | -- toIxedRec RecNil = HideIx IxedRecNil 886 | -- toIxedRec (r `RecCons` rs) = case toIxedRec rs of 887 | -- HideIx x -> HideIx (IxedRecCons r x) 888 | 889 | snocVec :: a -> Vec n a -> Vec ('S n) a 890 | snocVec a VecNil = VecCons a VecNil 891 | snocVec a (VecCons b vnext) = 892 | VecCons b (snocVec a vnext) 893 | 894 | pathToIxedPath :: Path f xs -> HideIx (IxedPath f) xs 895 | pathToIxedPath PathNil = HideIx IxedPathNil 896 | pathToIxedPath (PathConsCapture c pnext) = 897 | case pathToIxedPath pnext of 898 | HideIx ixed -> HideIx (IxedPathCapture c ixed) 899 | pathToIxedPath (PathConsMatch s pnext) = 900 | case pathToIxedPath pnext of 901 | HideIx ixed -> HideIx (IxedPathMatch s ixed) 902 | 903 | -- | Discards the static parts 904 | ixedPathToIxedRec :: IxedPath f n xs -> IxedRec f n xs 905 | ixedPathToIxedRec IxedPathNil = IxedRecNil 906 | ixedPathToIxedRec (IxedPathCapture c pnext) = 907 | IxedRecCons c (ixedPathToIxedRec pnext) 908 | ixedPathToIxedRec (IxedPathMatch _ pnext) = 909 | ixedPathToIxedRec pnext 910 | 911 | ixedPathToLenPath :: IxedPath f n xs -> LenPath n 912 | ixedPathToLenPath IxedPathNil = LenPathNil 913 | ixedPathToLenPath (IxedPathCapture _ pnext) = 914 | LenPathCapture (ixedPathToLenPath pnext) 915 | ixedPathToLenPath (IxedPathMatch s pnext) = 916 | LenPathMatch s (ixedPathToLenPath pnext) 917 | 918 | snocLenPathMatch :: T.Text -> LenPath n -> LenPath n 919 | snocLenPathMatch s x = case x of 920 | LenPathNil -> LenPathMatch s LenPathNil 921 | LenPathMatch t pnext -> LenPathMatch t (snocLenPathMatch s pnext) 922 | LenPathCapture pnext -> LenPathCapture (snocLenPathMatch s pnext) 923 | 924 | snocLenPathCapture :: LenPath n -> LenPath ('S n) 925 | snocLenPathCapture x = case x of 926 | LenPathNil -> LenPathCapture LenPathNil 927 | LenPathMatch t pnext -> LenPathMatch t (snocLenPathCapture pnext) 928 | LenPathCapture pnext -> LenPathCapture (snocLenPathCapture pnext) 929 | 930 | reverseLenPathMatch :: LenPath n -> LenPath n 931 | reverseLenPathMatch = go 932 | where 933 | go :: forall n. LenPath n -> LenPath n 934 | go LenPathNil = LenPathNil 935 | go (LenPathMatch s pnext) = snocLenPathMatch s (go pnext) 936 | go (LenPathCapture pnext) = snocLenPathCapture (go pnext) 937 | 938 | singletonIxedRouter :: 939 | route captures querys request response -> Method -> Path CaptureDecoding captures -> IxedRouter route 'Z 940 | singletonIxedRouter route method capDecs = case pathToIxedPath capDecs of 941 | HideIx ixedCapDecs -> 942 | let ixedCapDecsRec = ixedPathToIxedRec ixedCapDecs 943 | responder = IxedResponder route ixedCapDecsRec 944 | lenPath = reverseLenPathMatch (ixedPathToLenPath ixedCapDecs) 945 | in singletonIxedRouterHelper responder method lenPath 946 | 947 | singletonIxedRouterHelper :: 948 | IxedResponder route n -> Method -> LenPath n -> IxedRouter route 'Z 949 | singletonIxedRouterHelper responder method path = 950 | let r = IxedRouter HM.empty Nothing (HM.singleton (encodeMethod method) [responder]) 951 | in singletonIxedRouterGo r path 952 | 953 | singletonIxedRouterGo :: 954 | IxedRouter route n -> LenPath n -> IxedRouter route 'Z 955 | singletonIxedRouterGo r lp = case lp of 956 | LenPathNil -> r 957 | LenPathCapture lpNext -> singletonIxedRouterGo (IxedRouter HM.empty (Just r) HM.empty) lpNext 958 | LenPathMatch s lpNext -> singletonIxedRouterGo (IxedRouter (HM.singleton s r) Nothing HM.empty) lpNext 959 | 960 | unionIxedRouter :: IxedRouter route n -> IxedRouter route n -> IxedRouter route n 961 | unionIxedRouter = go 962 | where 963 | go :: forall route n. IxedRouter route n -> IxedRouter route n -> IxedRouter route n 964 | go (IxedRouter matchesA captureA respsA) (IxedRouter matchesB captureB respsB) = 965 | IxedRouter 966 | (HM.unionWith go matchesA matchesB) 967 | (unionMaybeWith go captureA captureB) 968 | (HM.unionWith (++) respsA respsB) 969 | 970 | unionMaybeWith :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a 971 | unionMaybeWith f x y = case x of 972 | Nothing -> y 973 | Just xval -> case y of 974 | Nothing -> x 975 | Just yval -> Just (f xval yval) 976 | 977 | -- | Pretty prints a router, using indentation to show nesting 978 | -- of routes under a common prefix. This also shows the request 979 | -- methods that each route accepts. If there are any trivially 980 | -- overlapped routes, the appends are asterisk to the method name 981 | -- for which the routes are overlapped. 982 | prettyRouter :: Router route -> String 983 | prettyRouter (Router r) = L.unlines (prettyIxedRouter 0 (Nothing,r)) 984 | 985 | prettyIxedRouter :: 986 | Int -- ^ Indentation 987 | -> (Maybe String, IxedRouter route n) 988 | -> [String] 989 | prettyIxedRouter indent (mnode,IxedRouter matches cap responders) = 990 | let spaces = L.replicate indent ' ' 991 | nextIndent = if isJust mnode then indent + 2 else indent 992 | children1 = map (first (Just . ('/' : ) . T.unpack)) (HM.toList matches) 993 | children2 = maybe [] (\x -> [(Just "/:capture",x)]) cap 994 | in concat 995 | [ case mnode of 996 | Nothing -> if length responders > 0 997 | then ["/ " ++ showRespondersList responders] 998 | else [] 999 | Just _ -> [] 1000 | , maybe [] (\x -> [x]) $ flip fmap mnode $ \node -> spaces 1001 | ++ node 1002 | ++ (if length responders > 0 then " " ++ showRespondersList responders else "") 1003 | , prettyIxedRouter nextIndent =<< children1 1004 | , prettyIxedRouter nextIndent =<< children2 1005 | ] 1006 | 1007 | showRespondersList :: HashMap T.Text [a] -> String 1008 | showRespondersList = id 1009 | . (\x -> "[" ++ x ++ "]") 1010 | . L.intercalate "," 1011 | . map (\(method,xs) -> T.unpack method ++ (if L.length xs > 1 then "*" else "")) 1012 | . HM.toList 1013 | 1014 | -- | Given a route type @Route@, generate a function 1015 | -- that looks like 1016 | -- 1017 | -- @ 1018 | -- allRoutes :: ['Constructed' Route] 1019 | -- allRoutes = ... 1020 | -- @ 1021 | -- 1022 | -- Which could be useful e.g. with 'routerWith'. 1023 | -- 1024 | -- This function makes two assumptions about your 1025 | -- route type: 1026 | -- 1027 | -- 1. It is kinded @['Type'] -> ['Param'] -> 'Bodiedness' -> 'Type' -> 'Type'@ 1028 | -- 2. Its value constructors have no arguments 1029 | -- 1030 | -- Example: 1031 | -- 1032 | -- @ 1033 | -- data Route :: ['Type'] -> ['Param'] -> 'Bodiedness' -> 'Type' -> 'Type' where 1034 | -- HelloWorld :: Route '[] '[] ''Bodyless' 'String' 1035 | -- GoodbyeWorld :: Route '[] '[] ''Bodyless' 'Data.Void.Void' 1036 | -- $(generateAllRoutes ''Route) 1037 | -- @ 1038 | -- 1039 | -- will generate: 1040 | -- 1041 | -- @ 1042 | -- allRoutes :: [Constructed Route] 1043 | -- allRoutes = [Constructed HelloWorld, Constructed GoodbyeWorld] 1044 | -- @ 1045 | -- 1046 | generateAllRoutes :: Name -> Q [Dec] 1047 | generateAllRoutes r = do 1048 | d <- THD.reifyDatatype r 1049 | hasConstructedKind (THD.datatypeVars d) 1050 | noConstructorArgs (THD.datatypeCons d) 1051 | let rhs = TH.ListE $ map 1052 | (\c -> TH.AppE 1053 | (TH.ConE 'Constructed) 1054 | (TH.ConE (THD.constructorName c)) 1055 | ) 1056 | (THD.datatypeCons d) 1057 | let name = TH.mkName "allRoutes" 1058 | -- N.B: When we use mkName here instead of a tick, 1059 | -- the generated code includes a ticked 1060 | -- @'Constructed@ instead of just @Constructed@. 1061 | -- Very strange, since I thought only 'PromotedT' 1062 | -- was supposed to do that. Also, to allow for 1063 | -- qualified imports we must fully qualify the name. 1064 | let typ = TH.AppT TH.ListT (TH.AppT (TH.ConT (TH.mkName "Trasa.Core.Constructed")) (TH.ConT (THD.datatypeName d))) 1065 | let bod = [TH.Clause [] (TH.NormalB rhs) []] 1066 | pure [TH.SigD name typ, TH.FunD name bod] 1067 | 1068 | -- Verify that the constructors all take no arguments. 1069 | noConstructorArgs :: [THD.ConstructorInfo] -> Q () 1070 | noConstructorArgs = go 1071 | where 1072 | msg = "generateAllRoutes expects all" 1073 | <> " constructors to have no arguments." 1074 | 1075 | go [] = pure () 1076 | go (c:cs) = case THD.constructorFields c of 1077 | [] -> go cs 1078 | _ -> fail msg 1079 | 1080 | -- Confirm the correct kind for 'generateAllRoutes'. Verifies that 1081 | -- the type has kind 1082 | -- 1083 | -- @['Type'] -> ['Param'] -> 'Bodiedness' -> 'Type' -> 'Type'@, 1084 | -- 1085 | -- which is the kind that 'Constructed' needs. 1086 | hasConstructedKind :: [TyVarBndr] -> Q () 1087 | hasConstructedKind = \case 1088 | [captures, queries, bodiedness, response] -> do 1089 | let correctKind = True 1090 | && isListType captures 1091 | && isListParam queries 1092 | && isBodiedness bodiedness 1093 | && isType response 1094 | unless correctKind $ fail msg 1095 | _ -> do 1096 | fail msg 1097 | where 1098 | msg = "generateAllRoutes expects a type" 1099 | ++ " with kind `[Type] -> [Param] -> Bodiedness" 1100 | ++ " -> Type -> Type`." 1101 | typeKind = TH.StarT 1102 | paramKind = TH.ConT ''Param 1103 | bodiednessKind = TH.ConT ''Bodiedness 1104 | isListType = \case 1105 | KindedTV _ (TH.AppT TH.ListT k) -> k == typeKind 1106 | _ -> False 1107 | isListParam = \case 1108 | KindedTV _ (TH.AppT TH.ListT k) -> k == paramKind 1109 | _ -> False 1110 | isBodiedness = \case 1111 | KindedTV _ k -> k == bodiednessKind 1112 | _ -> False 1113 | isType = \case 1114 | PlainTV _ -> True 1115 | KindedTV _ TH.StarT -> True 1116 | _ -> False 1117 | -------------------------------------------------------------------------------- /trasa/src/Trasa/Core/Implicit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Trasa.Core.Implicit 5 | ( 6 | HasMeta(..) 7 | , prepare 8 | , link 9 | , parse 10 | , EnumerableRoute(..) 11 | , router 12 | ) where 13 | 14 | import Data.Kind (Type) 15 | 16 | import Trasa.Core 17 | 18 | class HasMeta route where 19 | type CaptureStrategy route :: Type -> Type 20 | type CaptureStrategy route = CaptureCodec 21 | type QueryStrategy route :: Type -> Type 22 | type QueryStrategy route = CaptureCodec 23 | type RequestBodyStrategy route :: Type -> Type 24 | type RequestBodyStrategy route = Many BodyCodec 25 | type ResponseBodyStrategy route :: Type -> Type 26 | type ResponseBodyStrategy route = Many BodyCodec 27 | meta 28 | :: route caps qrys req resp 29 | -> Meta (CaptureStrategy route) (QueryStrategy route) (RequestBodyStrategy route) (ResponseBodyStrategy route) caps qrys req resp 30 | 31 | prepare 32 | :: HasMeta route 33 | => route captures queries request response 34 | -> Arguments captures queries request (Prepared route response) 35 | prepare = prepareWith meta 36 | 37 | link 38 | :: (HasMeta route, HasCaptureEncoding (CaptureStrategy route), HasCaptureEncoding (QueryStrategy route)) 39 | => Prepared route response 40 | -> Url 41 | link = linkWith toMeta 42 | where 43 | toMeta route = m 44 | { metaPath = mapPath captureEncoding (metaPath m) 45 | , metaQuery = mapQuery captureEncoding (metaQuery m) 46 | } 47 | where m = meta route 48 | 49 | parse 50 | :: ( HasMeta route 51 | , HasCaptureDecoding (CaptureStrategy route) 52 | , HasCaptureDecoding (QueryStrategy route) 53 | , RequestBodyStrategy route ~ Many strat 54 | , HasBodyDecoding strat 55 | , EnumerableRoute route ) 56 | => Method -- ^ Request Method 57 | -> Url -- ^ Everything after the authority 58 | -> Maybe Content -- ^ Request content type and body 59 | -> Either TrasaErr (Concealed route) 60 | parse = parseWith (mapMetaQuery captureDecoding . mapMetaRequestBody (mapMany bodyDecoding) . meta) router 61 | 62 | class EnumerableRoute route where 63 | enumerateRoutes :: [Constructed route] 64 | 65 | router 66 | :: (HasMeta route, HasCaptureDecoding (CaptureStrategy route), EnumerableRoute route) 67 | => Router route 68 | router = routerWith (mapMetaPath captureDecoding . meta) enumerateRoutes 69 | -------------------------------------------------------------------------------- /trasa/src/Trasa/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Trasa.Error 3 | ( 4 | -- * Types 5 | TrasaErr(..) 6 | -- * Simple Errors 7 | , status 8 | ) where 9 | 10 | import Control.Exception (Exception(..)) 11 | import qualified Data.ByteString.Lazy.Char8 as LBC 12 | import qualified Network.HTTP.Types as N 13 | 14 | data TrasaErr = TrasaErr 15 | { trasaErrStatus :: N.Status 16 | , trasaErrBody :: LBC.ByteString 17 | } deriving (Eq,Ord) 18 | 19 | instance Show TrasaErr where 20 | show (TrasaErr s b) = 21 | "Trasa Error with status: " ++ 22 | show s ++ 23 | if LBC.null b then "" else " and body: " ++ LBC.unpack b 24 | 25 | instance Exception TrasaErr where 26 | 27 | status :: N.Status -> TrasaErr 28 | status s = TrasaErr s "" 29 | 30 | -------------------------------------------------------------------------------- /trasa/src/Trasa/Method.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | -- | This module exports symbols that will conflict with the standard prelude. 4 | -- It is recommended to be import qualified or just import 'Method' and use its 'IsString' instance. 5 | module Trasa.Method 6 | ( 7 | -- * Method 8 | Method 9 | , encodeMethod 10 | , decodeMethod 11 | -- * Convenience pre defined methods 12 | , get 13 | , post 14 | , head 15 | , put 16 | , delete 17 | , trace 18 | , connect 19 | , options 20 | , patch 21 | ) where 22 | 23 | import Prelude hiding (head) 24 | import Data.Hashable(Hashable(..)) 25 | import Data.String (IsString(..)) 26 | import qualified Data.Text as T 27 | 28 | newtype Method = Method T.Text 29 | deriving (Hashable,Eq,Ord) 30 | 31 | instance Show Method where 32 | show = show . encodeMethod 33 | 34 | instance IsString Method where 35 | fromString = decodeMethod . T.pack 36 | 37 | encodeMethod :: Method -> T.Text 38 | encodeMethod (Method txt) = txt 39 | 40 | decodeMethod :: T.Text -> Method 41 | decodeMethod = Method . T.toUpper 42 | 43 | get :: Method 44 | get = "GET" 45 | 46 | post :: Method 47 | post = "POST" 48 | 49 | head :: Method 50 | head = "HEAD" 51 | 52 | put :: Method 53 | put = "PUT" 54 | 55 | delete :: Method 56 | delete = "DELETE" 57 | 58 | trace :: Method 59 | trace = "TRACE" 60 | 61 | connect :: Method 62 | connect = "CONNECT" 63 | 64 | options :: Method 65 | options = "OPTIONS" 66 | 67 | patch :: Method 68 | patch = "PATCH" 69 | 70 | -------------------------------------------------------------------------------- /trasa/src/Trasa/Tutorial.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 2 | 3 | {-| Users of this library should a data type representing all possible 4 | routes available in a web application. It is recommended that 5 | this type be named @Route@, but this is not required. 6 | -} 7 | 8 | module Trasa.Tutorial 9 | ( -- * Dispatch and Routing 10 | -- $dispatchandrouting 11 | ) where 12 | 13 | import Trasa.Core 14 | import qualified Trasa.Method as M 15 | import Data.Kind (Type) 16 | import Data.Text (Text) 17 | 18 | -- $setup 19 | -- >>> :set -XDataKinds 20 | -- >>> :set -XKindSignatures 21 | -- >>> :set -XGADTs 22 | -- >>> :set -XOverloadedStrings 23 | 24 | -- $dispatchandrouting 25 | -- In this example, we will write web application that maintains three 26 | -- counters. The end user will be able to perform various operations 27 | -- that manipulate the values of these counters and ask for their 28 | -- current value. We begin by defining our route type: 29 | -- 30 | -- >>> :{ 31 | -- data Counter = Red | Green | Blue 32 | -- deriving (Show,Read) 33 | -- data Route :: [Type] -> [Param] -> Bodiedness -> Type -> Type where 34 | -- AssignR :: Route '[Counter,Int] '[] 'Bodyless () 35 | -- IncrementR :: Route '[Counter] '[] 'Bodyless Int 36 | -- QueryR :: Route '[Counter] '[]Bodyless Int 37 | -- TotalR :: Route '[] '[] 'Bodyless Int 38 | -- int :: CaptureCodec Int 39 | -- int = showReadCaptureCodec 40 | -- counter :: CaptureCodec Counter 41 | -- counter = showReadCaptureCodec 42 | -- bodyUnit :: BodyCodec () 43 | -- bodyUnit = BodyCodec (pure "text/plain") (const "") (const (Right ())) 44 | -- bodyInt :: BodyCodec Int 45 | -- bodyInt = showReadBodyCodec 46 | -- meta :: Route captures querys request response -> MetaCodec captures querys request response 47 | -- meta x = metaBuilderToMetaCodec $ case x of 48 | -- AssignR -> Meta 49 | -- (match "assign" ./ capture counter ./ match "to" ./ capture int ./ end) 50 | -- qend 51 | -- bodyless (resp bodyUnit) M.post 52 | -- IncrementR -> Meta 53 | -- (match "increment" ./ capture counter ./ end) 54 | -- qend 55 | -- bodyless (resp bodyInt) M.post 56 | -- QueryR -> Meta 57 | -- (match "query" ./ capture counter ./ end) 58 | -- qend 59 | -- bodyless (resp bodyInt) M.get 60 | -- TotalR -> Meta 61 | -- (match "total" ./ end) 62 | -- qend 63 | -- bodyless (resp bodyInt) M.get 64 | -- :} 65 | -- 66 | -- Now, we can start using our routes. To do this, we take functions that 67 | -- @trasa@ exports and partially apply them to the route metadata that 68 | -- we have created. We can start with prepare and link: 69 | -- 70 | -- >>> prepare = prepareWith meta 71 | -- >>> :t prepare 72 | -- prepare 73 | -- :: Route captures query request response 74 | -- -> Arguments captures query request (Prepared Route response) 75 | -- >>> :{ 76 | -- link = linkWith (metaCodecToMetaClient . meta) 77 | -- :} 78 | -- 79 | -- >>> :t link 80 | -- link :: Prepared Route response -> Url 81 | -- 82 | -- Now we can use link to encode our routes: 83 | -- 84 | -- >>> link (prepare AssignR Green 5) 85 | -- "/assign/Green/to/5" 86 | -- 87 | -- 88 | -------------------------------------------------------------------------------- /trasa/src/Trasa/Url.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | module Trasa.Url 5 | ( 6 | -- * Untyped Query Parameters 7 | QueryParam(..) 8 | , QueryString(..) 9 | , encodeQuery 10 | , decodeQuery 11 | -- * Urls (path + query string) 12 | , Url(..) 13 | , encodeUrl 14 | , decodeUrl 15 | ) where 16 | 17 | import Data.Semigroup (Semigroup(..)) 18 | import qualified Data.ByteString.Lazy as LBS 19 | import qualified Data.ByteString.Builder as LBS 20 | import qualified Data.Text as T 21 | import qualified Data.Text.Encoding as T 22 | import qualified Data.HashMap.Strict as HM 23 | import qualified Network.HTTP.Types as N 24 | 25 | data QueryParam 26 | = QueryParamFlag 27 | | QueryParamSingle T.Text 28 | | QueryParamList [T.Text] 29 | deriving Eq 30 | 31 | instance Semigroup QueryParam where 32 | QueryParamFlag <> q = q 33 | q <> QueryParamFlag = q 34 | QueryParamSingle q1 <> QueryParamSingle q2 = QueryParamList [q1,q2] 35 | QueryParamSingle q1 <> QueryParamList l1 = QueryParamList (q1:l1) 36 | QueryParamList l1 <> QueryParamSingle q1 = QueryParamList (l1 ++ [q1]) -- O(n^2)... 37 | QueryParamList l1 <> QueryParamList l2 = QueryParamList (l1 ++ l2) 38 | 39 | instance Monoid QueryParam where 40 | mempty = QueryParamFlag 41 | mappend = (<>) 42 | 43 | newtype QueryString = QueryString 44 | { unQueryString :: HM.HashMap T.Text QueryParam 45 | } deriving Eq 46 | 47 | encodeQuery :: QueryString -> N.Query 48 | encodeQuery = HM.foldrWithKey (\key param items -> toQueryItem key param ++ items) [] . unQueryString 49 | where 50 | toQueryItem :: T.Text -> QueryParam -> N.Query 51 | toQueryItem key = \case 52 | QueryParamFlag -> [(T.encodeUtf8 key, Nothing)] 53 | QueryParamSingle value -> [(T.encodeUtf8 key, Just (T.encodeUtf8 value))] 54 | QueryParamList values -> 55 | flip fmap values $ \value -> (T.encodeUtf8 key, Just (T.encodeUtf8 value)) 56 | 57 | decodeQuery :: N.Query -> QueryString 58 | decodeQuery = QueryString . HM.fromListWith (<>) . fmap decode 59 | where 60 | decode (key,mval) = case mval of 61 | Nothing -> (tkey,QueryParamFlag) 62 | Just val -> (tkey,QueryParamSingle (T.decodeUtf8 val)) 63 | where tkey = T.decodeUtf8 key 64 | 65 | data Url = Url 66 | { urlPath :: ![T.Text] 67 | , urlQueryString :: !QueryString 68 | } deriving Eq 69 | 70 | instance Show Url where 71 | show = show . encodeUrl 72 | 73 | encodeUrl :: Url -> T.Text 74 | encodeUrl (Url path querys) = 75 | ( T.decodeUtf8 76 | . LBS.toStrict 77 | . LBS.toLazyByteString 78 | . encode 79 | . encodeQuery ) querys 80 | where 81 | encode qs = case path of 82 | [] -> "/" <> N.encodePath path qs 83 | _ -> N.encodePath path qs 84 | 85 | decodeUrl :: T.Text -> Url 86 | decodeUrl txt = Url path (decodeQuery querys) 87 | where (path,querys) = N.decodePath (T.encodeUtf8 txt) 88 | -------------------------------------------------------------------------------- /trasa/test/Doctest.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.DocTest (doctest) 4 | 5 | main :: IO () 6 | main = do 7 | putStrLn "\nRUNNING DOCTESTS" 8 | doctest 9 | [ "src" 10 | ] 11 | -------------------------------------------------------------------------------- /trasa/test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE InstanceSigs #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | 13 | import Data.Exists 14 | import Data.Functor.Identity 15 | import Data.Kind (Type) 16 | import Data.Monoid 17 | import Test.Tasty 18 | import Test.Tasty.HUnit 19 | import Test.Tasty.QuickCheck as QC 20 | import Text.Read (readMaybe) 21 | import Topaz.Rec 22 | import Trasa.Core 23 | import Trasa.Core.Implicit 24 | import qualified Data.ByteString.Lazy.Char8 as LBSC 25 | import qualified Data.Text as T 26 | import qualified Trasa.Method as M 27 | 28 | main :: IO () 29 | main = do 30 | putStrLn "\nPRETTY ROUTER" 31 | putStrLn (prettyRouter (router @Route)) 32 | putStrLn "\nRUNNING OTHER TESTS" 33 | defaultMain tests 34 | 35 | tests :: TestTree 36 | tests = testGroup "Tests" [properties, unitTests] 37 | 38 | -- todo: add a property test to show that parse and link 39 | -- form a partial isomorphism. 40 | properties :: TestTree 41 | properties = testGroup "Properties" 42 | [ QC.testProperty "roundtrip link parse" roundtripLinkParse 43 | ] 44 | 45 | unitTests :: TestTree 46 | unitTests = testGroup "Unit Tests" 47 | [ testCase "link addition route" 48 | $ link (prepare AdditionR 12 5 (Just 3)) @?= decodeUrl "/add/12/5?more=3" 49 | , testCase "link left pad route" 50 | $ link (prepare LeftPadR 5 "foo") @?= decodeUrl "/pad/left/5" 51 | , testCase "parse hello route" 52 | $ parseUrl "/hello" @?= Right (conceal (prepare HelloR)) 53 | , testCase "parse addition route" 54 | $ parseUrl "/add/6/3" @?= Right (conceal (prepare AdditionR 6 3 Nothing)) 55 | ] 56 | 57 | parseUrl :: T.Text -> Either TrasaErr (Concealed Route) 58 | parseUrl url = parse "GET" (decodeUrl url) Nothing 59 | 60 | data Route :: [Type] -> [Param] -> Bodiedness -> Type -> Type where 61 | EmptyR :: Route '[] '[] Bodyless Int 62 | HelloR :: Route '[] '[] Bodyless Int 63 | AdditionR :: Route '[Int,Int] '[Optional Int] Bodyless Int 64 | IdentityR :: Route '[String] '[] Bodyless String 65 | LeftPadR :: Route '[Int] '[] (Body String) String 66 | TrickyOneR :: Route '[Int] '[] Bodyless String 67 | TrickyTwoR :: Route '[Int,Int] '[] Bodyless String 68 | 69 | instance EnumerableRoute Route where 70 | enumerateRoutes = 71 | [ Constructed HelloR 72 | , Constructed AdditionR 73 | , Constructed IdentityR 74 | , Constructed LeftPadR 75 | , Constructed TrickyOneR 76 | , Constructed TrickyTwoR 77 | , Constructed EmptyR 78 | ] 79 | 80 | instance HasMeta Route where 81 | type CaptureStrategy Route = CaptureCodec 82 | type QueryStrategy Route = CaptureCodec 83 | type RequestBodyStrategy Route = Many BodyCodec 84 | type ResponseBodyStrategy Route = Many BodyCodec 85 | meta :: Route ps qs rq rp -> MetaCodec ps qs rq rp 86 | meta x = metaBuilderToMetaCodec $ case x of 87 | EmptyR -> Meta 88 | end 89 | qend 90 | bodyless (resp bodyInt) M.get 91 | HelloR -> Meta 92 | (match "hello" ./ end) 93 | qend 94 | bodyless (resp bodyInt) M.get 95 | AdditionR -> Meta 96 | (match "add" ./ capture int ./ capture int ./ end) 97 | (optional "more" int .& qend) 98 | bodyless (resp bodyInt) M.get 99 | IdentityR -> Meta 100 | (match "identity" ./ capture string ./ end) 101 | qend 102 | bodyless (resp bodyString) M.get 103 | LeftPadR -> Meta 104 | (match "pad" ./ match "left" ./ capture int ./ end) 105 | qend 106 | (body bodyString) (resp bodyString) M.get 107 | TrickyOneR -> Meta 108 | (match "tricky" ./ capture int ./ match "one" ./ end) 109 | qend 110 | bodyless (resp bodyString) M.get 111 | TrickyTwoR -> Meta 112 | (capture int ./ capture int ./ match "two" ./ end) 113 | qend 114 | bodyless (resp bodyString) M.get 115 | 116 | int :: CaptureCodec Int 117 | int = CaptureCodec (T.pack . show) (readMaybe . T.unpack) 118 | 119 | string :: CaptureCodec String 120 | string = CaptureCodec T.pack (Just . T.unpack) 121 | 122 | bodyString :: BodyCodec String 123 | bodyString = BodyCodec (pure "text/plain") LBSC.pack (Right . LBSC.unpack) 124 | 125 | bodyUnit :: BodyCodec () 126 | bodyUnit = BodyCodec (pure "text/plain") (const "") (const (Right ())) 127 | 128 | note :: e -> Maybe a -> Either e a 129 | note e Nothing = Left e 130 | note _ (Just x) = Right x 131 | 132 | bodyInt :: BodyCodec Int 133 | bodyInt = BodyCodec (pure "text/plain") (LBSC.pack . show) 134 | (note "Could not decode int" . readMaybe . LBSC.unpack) 135 | 136 | roundtripLinkParse :: Concealed Route -> Property 137 | roundtripLinkParse c@(Concealed route captures querys reqBody) = 138 | (case reqBody of 139 | RequestBodyPresent _ -> False 140 | RequestBodyAbsent -> True 141 | ) 142 | ==> 143 | Right c == parseUrl (encodeUrl (link (Prepared route captures querys reqBody))) 144 | 145 | {- 146 | -- | Includes the route, path, query parameters, and request body. 147 | data Prepared :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Type -> Type where 148 | Prepared :: 149 | !(route captures querys request response) 150 | -> !(Rec Identity captures) 151 | -> !(Rec Parameter querys) 152 | -> !(RequestBody Identity request) 153 | -> Prepared route response 154 | 155 | -- | Only needed to implement 'parseWith'. Most users do not need this. 156 | -- If you need to create a route hierarchy to provide breadcrumbs, 157 | -- then you will need this. 158 | data Concealed :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Type where 159 | Concealed :: 160 | !(route captures querys request response) 161 | -> !(Rec Identity captures) 162 | -> !(Rec Parameter querys) 163 | -> !(RequestBody Identity request) 164 | -> Concealed route 165 | -} 166 | 167 | -- This instance is defined only so that the test suite can do 168 | -- its job. It not not neccessary or recommended to write this 169 | -- instance in production code. 170 | instance Eq (Concealed Route) where 171 | Concealed rt1 (ps1 :: _) qs1 rq1 == Concealed rt2 ps2 qs2 rq2 = case (rt1,rt2) of 172 | (AdditionR,AdditionR) -> ps1 == ps2 && qs1 == qs2 && rq1 == rq2 173 | (IdentityR,IdentityR) -> ps1 == ps2 && qs1 == qs2 && rq1 == rq2 174 | (LeftPadR,LeftPadR) -> case (rq1,rq2) of 175 | (RequestBodyPresent a, RequestBodyPresent b) -> ps1 == ps2 && qs1 == qs2 && a == b 176 | (TrickyOneR,TrickyOneR) -> ps1 == ps2 && qs1 == qs2 && rq1 == rq2 177 | (TrickyTwoR,TrickyTwoR) -> ps1 == ps2 && qs1 == qs2 && rq1 == rq2 178 | (HelloR,HelloR) -> ps1 == ps2 && qs1 == qs2 && rq1 == rq2 179 | (EmptyR,EmptyR) -> ps1 == ps2 && qs1 == qs2 && rq1 == rq2 180 | 181 | instance Arbitrary (Concealed Route) where 182 | arbitrary = oneof 183 | [ Concealed AdditionR <$> arbitrary <*> arbitrary <*> arbitrary 184 | , Concealed IdentityR <$> arbitrary <*> arbitrary <*> arbitrary 185 | , Concealed LeftPadR <$> arbitrary <*> arbitrary <*> arbitrary 186 | , Concealed TrickyOneR <$> arbitrary <*> arbitrary <*> arbitrary 187 | , Concealed TrickyTwoR <$> arbitrary <*> arbitrary <*> arbitrary 188 | , Concealed HelloR <$> arbitrary <*> arbitrary <*> arbitrary 189 | , Concealed EmptyR <$> arbitrary <*> arbitrary <*> arbitrary 190 | ] 191 | 192 | instance Show (Concealed Route) where 193 | show (Concealed r a q b) = show (link (Prepared r a q b)) 194 | 195 | instance Eq a => Eq (Parameter (Optional a)) where 196 | ParameterOptional m1 == ParameterOptional m2 = m1 == m2 197 | 198 | instance Arbitrary (Rec Identity '[]) where 199 | arbitrary = pure RNil 200 | 201 | instance (Arbitrary r, Arbitrary (Rec Identity rs)) => Arbitrary (Rec Identity (r ': rs)) where 202 | arbitrary = (:&) <$> (Identity <$> arbitrary) <*> arbitrary 203 | 204 | instance Arbitrary (Rec Parameter '[]) where 205 | arbitrary = pure RNil 206 | 207 | instance (Arbitrary r, Arbitrary (Rec Parameter rs)) => Arbitrary (Rec Parameter (Optional r ': rs)) where 208 | arbitrary = (:&) <$> (ParameterOptional <$> arbitrary) <*> arbitrary 209 | 210 | instance Arbitrary (RequestBody f 'Bodyless) where 211 | arbitrary = pure RequestBodyAbsent 212 | 213 | instance Arbitrary a => Arbitrary (RequestBody Identity (Body a)) where 214 | arbitrary = RequestBodyPresent . Identity <$> arbitrary 215 | 216 | instance Eq (RequestBody f 'Bodyless) where 217 | RequestBodyAbsent == RequestBodyAbsent = True 218 | -------------------------------------------------------------------------------- /trasa/trasa.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: 3 | trasa 4 | version: 5 | 0.4.1 6 | synopsis: 7 | Type Safe Web Routing 8 | description: 9 | This library is a solution for http-based routing and dispatch. Its 10 | goals are similar to the goals of `servant`, however, `trasa` relies 11 | on very different mechanisms to accomplish those goals. All typeclasses 12 | in this library are optional. All of the real work is accomplished with GADTs, 13 | universal quantification, and plain old haskell data types. 14 | homepage: 15 | https://github.com/haskell-trasa/trasa 16 | author: 17 | Andrew Martin 18 | Kyle McKean 19 | maintainer: 20 | Andrew Martin 21 | Kyle McKean 22 | chessai 23 | license: 24 | MIT 25 | license-file: 26 | LICENSE 27 | copyright: 28 | © 2017-2019 Andrew Martin 29 | © 2017-2019 Kyle McKean 30 | category: 31 | Web 32 | build-type: 33 | Simple 34 | 35 | library 36 | hs-source-dirs: 37 | src 38 | exposed-modules: 39 | Trasa.Method 40 | Trasa.Url 41 | Trasa.Codec 42 | Trasa.Error 43 | Trasa.Core 44 | Trasa.Core.Implicit 45 | -- Trasa.Tutorial 46 | build-depends: 47 | , aeson >= 1.2 && < 1.5 48 | , base >= 4.9 && < 5 49 | , binary >= 0.8 && < 0.9 50 | , bytestring >= 0.10 && < 0.11 51 | , hashable >= 1.2 && < 1.4 52 | , http-media >= 0.6 && < 0.9 53 | , http-types >= 0.9 54 | , quantification >= 0.5 && < 0.6 55 | , template-haskell >= 2.12 && < 2.17 56 | , th-abstraction >= 0.3 && < 0.4 57 | , text >= 1.2 && < 1.3 58 | , unordered-containers >= 0.2 && < 0.3 59 | default-language: 60 | Haskell2010 61 | ghc-options: 62 | -Wall -O2 63 | 64 | test-suite doctest 65 | type: 66 | exitcode-stdio-1.0 67 | hs-source-dirs: 68 | test 69 | main-is: 70 | Doctest.hs 71 | build-depends: 72 | , base 73 | , doctest 74 | default-language: 75 | Haskell2010 76 | 77 | --test-suite test 78 | -- type: 79 | -- exitcode-stdio-1.0 80 | -- hs-source-dirs: 81 | -- test 82 | -- main-is: 83 | -- Main.hs 84 | -- build-depends: 85 | -- base 86 | -- , trasa 87 | -- , tasty 88 | -- , tasty-quickcheck 89 | -- , tasty-hunit 90 | -- , bytestring 91 | -- , text 92 | -- , quantification 93 | -- ghc-options: 94 | -- -threaded 95 | -- -rtsopts -with-rtsopts=-N 96 | -- default-language: 97 | -- Haskell2010 98 | 99 | source-repository head 100 | type: git 101 | location: https://github.com/haskell-trasa/trasa 102 | --------------------------------------------------------------------------------