├── .github ├── dependabot.yml └── workflows │ └── ci.yaml ├── .gitignore ├── README.md ├── _config.yml ├── airship ├── Changes.md ├── LICENSE ├── README.md ├── airship.cabal ├── src │ ├── Airship.hs │ └── Airship │ │ ├── Config.hs │ │ ├── Headers.hs │ │ ├── Helpers.hs │ │ ├── Internal │ │ ├── Date.hs │ │ ├── Decision.hs │ │ ├── Helpers.hs │ │ ├── Parsers.hs │ │ └── Route.hs │ │ ├── RST.hs │ │ ├── Resource.hs │ │ ├── Resource │ │ └── Static.hs │ │ ├── Route.hs │ │ └── Types.hs └── test │ └── unit │ └── test.hs ├── cabal.project ├── doc ├── authorisation.md └── versioning-apis.md └── example ├── Basic.hs ├── LICENSE ├── Setup.hs ├── Versions.hs └── airship-example.cabal /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | 4 | # Maintain dependencies for GitHub Actions 5 | - package-ecosystem: "github-actions" 6 | directory: "/" 7 | schedule: 8 | interval: "monthly" 9 | -------------------------------------------------------------------------------- /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | push: 4 | branches: 5 | - master 6 | pull_request: 7 | types: 8 | - opened 9 | - synchronize 10 | jobs: 11 | build: 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | cabal: ["3.6"] 16 | ghc: ["8.2.2", "8.4.4", "8.6.5", "8.8.4", "8.10.7", "9.2.4"] 17 | os: 18 | - macos-latest 19 | - ubuntu-latest 20 | 21 | runs-on: ${{ matrix.os }} 22 | steps: 23 | - uses: actions/checkout@v3 24 | - uses: haskell/actions/setup@v2 25 | id: setup-haskell-cabal 26 | with: 27 | ghc-version: ${{ matrix.ghc }} 28 | cabal-version: ${{ matrix.cabal }} 29 | - name: Cabal Update 30 | run: | 31 | cabal v2-update 32 | cabal v2-freeze $CONFIG 33 | - uses: actions/cache@v3.0.5 34 | with: 35 | path: | 36 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 37 | dist-newstyle 38 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 39 | restore-keys: | 40 | ${{ runner.os }}-${{ matrix.ghc }}- 41 | - name: Build all 42 | run: | 43 | cabal build all 44 | cabal sdist all 45 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | cabal.sandbox.config 2 | dist 3 | dist-newstyle/ 4 | .cabal-sandbox/ 5 | *.o 6 | *.hi 7 | *.chi 8 | *.chs.h 9 | .virthualenv 10 | .DS_Store 11 | .stack-work/ 12 | TAGS 13 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Airship 2 | 3 | [![GitHub CI][github-shield]][github-ci] [![docs][docs-shield]][docs] 4 | 5 | Airship is a Haskell library for handling and serving HTTP requests in a RESTful fashion. It is heavily inspired by [Webmachine](https://github.com/basho/webmachine) 6 | and works with any [WAI](https://hackage.haskell.org/package/wai)-compatible web server such as [Warp](https://hackage.haskell.org/package/warp). 7 | 8 | It aims to be small, fast, and flexible. 9 | 10 | # How does it work? 11 | 12 | Airship resources are represented with a [`Resource` record type](https://github.com/tmcgilchrist/airship/blob/master/airship/src/Airship/Resource.hs#L39-L117). 13 | Each field in `Resource` corresponds to an action taken in the [Webmachine decision tree](https://raw.githubusercontent.com/wiki/Webmachine/webmachine/images/http-headers-status-v3.png). 14 | Airship provides a `defaultResource` with sensible defaults for each of these actions; you build web services by overriding fields in the default resource with your own. 15 | 16 | Routes are declared with a simple monadic syntax: 17 | 18 | ```haskell 19 | routes = do 20 | root #> someRootResource 21 | "account" var "name" #> accountResource 22 | ``` 23 | 24 | For a simple example that handles HTTP GET and POST requests, please check [`example/Basic.hs`](https://github.com/tmcgilchrist/airship/blob/master/example/Basic.hs). 25 | For a slightly more involved example that generates HTML and manages a pool of resources, please check the [blimp](https://github.com/patrickt/blimp) repository. 26 | 27 | Airship is copyright © 2015 Helium Systems, Inc., and released to the public under the terms of the MIT license. 28 | 29 | [github-shield]: https://github.com/tmcgilchrist/airship/actions/workflows/ci.yaml/badge.svg 30 | [github-ci]: https://github.com/tmcgilchrist/airship/actions/workflows/ci.yaml 31 | 32 | [docs-shield]:https://img.shields.io/badge/doc-online-blue.svg 33 | [docs]: https://tmcgilchrist.github.io/airship/index.html 34 | -------------------------------------------------------------------------------- /_config.yml: -------------------------------------------------------------------------------- 1 | theme: jekyll-theme-slate -------------------------------------------------------------------------------- /airship/Changes.md: -------------------------------------------------------------------------------- 1 | * 0.9.5 2 | - Maintenance release bumps upper bounds and add support for GHC 9.2.2. 3 | 4 | * 0.9.4 5 | - Bump upper bounds on bytestring-trie 6 | - Support GHC 8.4 and 8.6 7 | 8 | * 0.9.3 9 | - Bump upper bound on http-types due to stackage. 10 | 11 | * 0.9.0 12 | - Handle unspecified content-type (#107) 13 | - Unroll internal webmachine monad (#108) 14 | - Support for GHC 8.2.1 15 | - Various bugfixes 16 | -------------------------------------------------------------------------------- /airship/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Helium Systems, Inc. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | 22 | Portions of this software have been extracted from the Snap framework, 23 | which is licensed under the three-clause BSD license. 24 | 25 | Copyright (c) 2009, Snap Framework authors (see CONTRIBUTORS) 26 | All rights reserved. 27 | 28 | Portions of this software have been extracted from Kazu Yamamoto's 29 | http-date library, which is licensed under the three-clause BSD license. 30 | 31 | Copyright (c) 2009, IIJ Innovation Institute Inc. 32 | All rights reserved. 33 | 34 | Redistribution and use in source and binary forms, with or without 35 | modification, are permitted provided that the following conditions are met: 36 | 37 | Redistributions of source code must retain the above copyright notice, this 38 | list of conditions and the following disclaimer. 39 | 40 | Redistributions in binary form must reproduce the above copyright notice, this 41 | list of conditions and the following disclaimer in the documentation and/or 42 | other materials provided with the distribution. 43 | 44 | Neither the name of the Snap Framework authors nor the names of its 45 | contributors may be used to endorse or promote products derived from this 46 | software without specific prior written permission. 47 | 48 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 49 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 50 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 51 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 52 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 53 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 54 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 55 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 56 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 57 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 58 | -------------------------------------------------------------------------------- /airship/README.md: -------------------------------------------------------------------------------- 1 | ../README.md -------------------------------------------------------------------------------- /airship/airship.cabal: -------------------------------------------------------------------------------- 1 | name: airship 2 | synopsis: A Webmachine-inspired HTTP library 3 | homepage: https://github.com/tmcgilchrist/airship/ 4 | bug-reports: https://github.com/tmcgilchrist/airship/issues 5 | version: 0.9.5 6 | license: MIT 7 | license-file: LICENSE 8 | author: Reid Draper and Patrick Thomson 9 | maintainer: Tim McGilchrist 10 | category: Web 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | description: 14 | A Webmachine-inspired HTTP library based off ideas from the original Erlang project 15 | . 16 | A number of examples can be found in illustrating how to build airship based services. 17 | 18 | tested-with: 19 | GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.2.2 20 | 21 | extra-source-files: 22 | Changes.md 23 | README.md 24 | 25 | source-repository head 26 | type: git 27 | location: https://github.com/tmcgilchrist/airship.git 28 | 29 | library 30 | default-language: Haskell2010 31 | hs-source-dirs: src 32 | ghc-options: -Wall 33 | exposed-modules: 34 | Airship 35 | Airship.Config 36 | Airship.Headers 37 | Airship.Helpers 38 | Airship.Resource 39 | Airship.Resource.Static 40 | Airship.Route 41 | Airship.RST 42 | Airship.Types 43 | 44 | other-modules: 45 | Airship.Internal.Date 46 | Airship.Internal.Decision 47 | Airship.Internal.Helpers 48 | Airship.Internal.Parsers 49 | Airship.Internal.Route 50 | 51 | build-depends: 52 | attoparsec 53 | , base >=4.7 && <5 54 | , base64-bytestring >=1.0 && <1.3 55 | , blaze-builder >=0.3 && <0.5 56 | , bytestring 57 | , bytestring-trie >=0.2.4 && <0.3 58 | , case-insensitive 59 | , containers 60 | , cryptohash >=0.11 && <0.12 61 | , directory 62 | , either >=4.3 && <6.0 63 | , filepath >=1.3 && <1.5 64 | , http-date 65 | , http-media 66 | , http-types >=0.8 && <0.13 67 | , lifted-base >=0.2 && <0.3 68 | , microlens 69 | , mime-types >=0.1.0 && <0.1.1 70 | , mmorph >=1.0 && <1.3 71 | , monad-control >=1.0 72 | , mtl 73 | , network 74 | , old-locale 75 | , random 76 | , semigroups >=0.18 && <0.21 77 | , text 78 | , time 79 | , transformers 80 | , transformers-base 81 | , unix >=2.7 && <2.8 82 | , unordered-containers 83 | , wai >=3.0.3.0 && <3.3 84 | , wai-extra >=3.0 && <3.2 85 | 86 | -- https://github.com/yesodweb/wai/pull/726 87 | test-suite unit 88 | default-language: Haskell2010 89 | type: exitcode-stdio-1.0 90 | hs-source-dirs: test/unit 91 | main-is: test.hs 92 | build-depends: 93 | airship 94 | , base >=4.7 && <5 95 | , bytestring >=0.9.1 && <0.11 96 | , tasty >=0.10.1 && <1.3 97 | , tasty-hunit >=0.9.1 && <0.11 98 | , tasty-quickcheck >=0.8.3 && <0.11 99 | , text >=1.2 && <2.0 100 | , transformers 101 | , wai >=3.0 && <3.3 102 | 103 | ghc-options: -Wall -threaded -fno-warn-orphans 104 | -------------------------------------------------------------------------------- /airship/src/Airship.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | module Airship 5 | ( module Airship.Config 6 | , module Airship.Resource 7 | , module Airship.Headers 8 | , module Airship.Helpers 9 | , module Airship.Route 10 | , module Airship.Types 11 | ) where 12 | 13 | import Airship.Config 14 | import Airship.Headers 15 | import Airship.Helpers 16 | import Airship.Resource 17 | import Airship.Route 18 | import Airship.Types 19 | -------------------------------------------------------------------------------- /airship/src/Airship/Config.hs: -------------------------------------------------------------------------------- 1 | module Airship.Config 2 | ( AirshipConfig 3 | , HeaderInclusion (..) 4 | , includeTraceHeader 5 | , includeQuipHeader 6 | , defaultAirshipConfig 7 | ) where 8 | 9 | import Lens.Micro (Lens', lens) 10 | 11 | -- | An opaque data type encapsulating all Airship-specific configuration options. 12 | -- 13 | -- We use lenses to modify 'AirshipConfig' values -- though Airship only depends on the 14 | -- microlens library, its lenses are compatible with Control.Lens. 15 | data AirshipConfig = AirshipConfig 16 | { _includeTraceHeader :: HeaderInclusion 17 | , _includeQuipHeader :: HeaderInclusion 18 | } 19 | 20 | data HeaderInclusion = IncludeHeader | OmitHeader deriving (Eq, Show) 21 | 22 | -- | Determines whether or not the @Airship-Trace@ header, which traces the execution of 23 | -- a given request in the Airship decision tree, is included in every HTTP response. 24 | -- While exposing the decision tree is usually innocuous (and makes for significantly easier 25 | -- debugging), you may want to turn it off in certain circumstances. 26 | -- 27 | -- Defaults to 'IncludeHeader' (enabled). 28 | includeTraceHeader :: Lens' AirshipConfig HeaderInclusion 29 | includeTraceHeader = lens _includeTraceHeader (\s n -> s { _includeTraceHeader = n }) 30 | 31 | -- | Determines whether or not the @Airship-Quip@ header, which includes a pithy 32 | -- quote in your response headers, is included in every HTTP response. 33 | -- 34 | -- Defaults to 'IncludeHeader' (enabled). 35 | includeQuipHeader :: Lens' AirshipConfig HeaderInclusion 36 | includeQuipHeader = lens _includeQuipHeader (\s n -> s { _includeQuipHeader = n }) 37 | 38 | -- | The default configuration. Use this, in conjunction with the lenses declared 39 | -- above, to get and modify an 'AirshipConfig' to pass to 'resourceToWai'. 40 | defaultAirshipConfig :: AirshipConfig 41 | defaultAirshipConfig = AirshipConfig IncludeHeader IncludeHeader 42 | -------------------------------------------------------------------------------- /airship/src/Airship/Headers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module Airship.Headers 4 | ( addResponseHeader 5 | , modifyResponseHeaders 6 | ) where 7 | 8 | import Airship.Types (Webmachine, ResponseState(..)) 9 | import Control.Monad.State.Class (modify) 10 | import Network.HTTP.Types (ResponseHeaders, Header) 11 | 12 | -- | Applies the given function to the 'ResponseHeaders' present in this handlers 'ResponseState'. 13 | modifyResponseHeaders :: Monad m => (ResponseHeaders -> ResponseHeaders) -> Webmachine m () 14 | modifyResponseHeaders f = modify updateHeaders 15 | where updateHeaders rs@ResponseState{stateHeaders = h} = rs { stateHeaders = f h } 16 | 17 | -- | Adds a given 'Header' to this handler's 'ResponseState'. 18 | addResponseHeader :: Monad m => Header -> Webmachine m () 19 | addResponseHeader h = modifyResponseHeaders (h :) 20 | -------------------------------------------------------------------------------- /airship/src/Airship/Helpers.hs: -------------------------------------------------------------------------------- 1 | module Airship.Helpers 2 | ( parseFormData 3 | , contentTypeMatches 4 | , redirectTemporarily 5 | , redirectPermanently 6 | , resourceToWai 7 | , resourceToWaiT 8 | , resourceToWaiT' 9 | , appendRequestPath 10 | , lookupParam 11 | , lookupParam' 12 | ) where 13 | 14 | import Airship.Internal.Helpers 15 | -------------------------------------------------------------------------------- /airship/src/Airship/Internal/Date.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | {- 5 | Portions of this file are copyright (c) 2009, IIJ Innovation Institute Inc. 6 | The utcTimeToRfc1123 function was extracted from http-date, with slight 7 | modifications to operate on UTCTime values. 8 | -} 9 | 10 | module Airship.Internal.Date 11 | ( parseRfc1123Date 12 | , utcTimeToRfc1123) where 13 | 14 | #if __GLASGOW_HASKELL__ < 710 15 | import Control.Applicative ((<$>)) 16 | #endif 17 | 18 | import Data.ByteString.Char8 () 19 | import Data.ByteString.Internal 20 | import Data.Time.Calendar (fromGregorian, toGregorian) 21 | import Data.Time.Calendar.WeekDate (toWeekDate) 22 | import Data.Time.Clock (UTCTime (..), secondsToDiffTime) 23 | import Data.Word 24 | import Foreign.ForeignPtr 25 | import Foreign.Ptr 26 | import Foreign.Storable 27 | 28 | import qualified Network.HTTP.Date as HD 29 | 30 | httpDateToUtc :: HD.HTTPDate -> UTCTime 31 | httpDateToUtc h = UTCTime days diffTime 32 | where days = fromGregorian (fromIntegral $ HD.hdYear h) (HD.hdMonth h) (HD.hdDay h) 33 | diffTime = secondsToDiffTime seconds 34 | seconds = fromIntegral $ hourS + minS + HD.hdSecond h 35 | hourS = HD.hdHour h * 60 * 60 36 | minS = HD.hdMinute h * 60 37 | 38 | parseRfc1123Date :: ByteString -> Maybe UTCTime 39 | parseRfc1123Date b = httpDateToUtc <$> HD.parseHTTPDate b 40 | 41 | utcTimeToRfc1123 :: UTCTime -> ByteString 42 | utcTimeToRfc1123 (UTCTime day offset) = 43 | unsafeCreate 29 $ \ptr -> do 44 | cpy3 ptr weekDays (3 * w) 45 | poke (ptr `plusPtr` 3) comma 46 | poke (ptr `plusPtr` 4) spc 47 | int2 (ptr `plusPtr` 5) d 48 | poke (ptr `plusPtr` 7) spc 49 | cpy3 (ptr `plusPtr` 8) months (3 * m) 50 | poke (ptr `plusPtr` 11) spc 51 | int4 (ptr `plusPtr` 12) y 52 | poke (ptr `plusPtr` 16) spc 53 | int2 (ptr `plusPtr` 17) h 54 | poke (ptr `plusPtr` 19) colon 55 | int2 (ptr `plusPtr` 20) n 56 | poke (ptr `plusPtr` 22) colon 57 | int2 (ptr `plusPtr` 23) s 58 | poke (ptr `plusPtr` 25) spc 59 | poke (ptr `plusPtr` 26) (71 :: Word8) 60 | poke (ptr `plusPtr` 27) (77 :: Word8) 61 | poke (ptr `plusPtr` 28) (84 :: Word8) 62 | where 63 | y = fromIntegral y' 64 | offset' = round offset 65 | h = offset' `mod` 3600 66 | n = offset' `mod` 60 67 | s = offset' - (h * 3600) - (n * 60) 68 | (y', m, d) = toGregorian day 69 | (_, _, w) = toWeekDate day 70 | cpy3 :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO () 71 | cpy3 ptr p o = withForeignPtr p $ \fp -> 72 | memcpy ptr (fp `plusPtr` o) 3 73 | 74 | ---------------------------------------------------------------- 75 | 76 | int2 :: Ptr Word8 -> Int -> IO () 77 | int2 ptr n 78 | | n < 10 = do 79 | poke ptr zero 80 | poke (ptr `plusPtr` 1) (i2w8 n) 81 | | otherwise = do 82 | poke ptr (i2w8 (n `quot` 10)) 83 | poke (ptr `plusPtr` 1) (i2w8 (n `rem` 10)) 84 | 85 | int4 :: Ptr Word8 -> Int -> IO () 86 | int4 ptr n0 = do 87 | let (n1,x1) = n0 `quotRem` 10 88 | (n2,x2) = n1 `quotRem` 10 89 | (x4,x3) = n2 `quotRem` 10 90 | poke ptr (i2w8 x4) 91 | poke (ptr `plusPtr` 1) (i2w8 x3) 92 | poke (ptr `plusPtr` 2) (i2w8 x2) 93 | poke (ptr `plusPtr` 3) (i2w8 x1) 94 | 95 | i2w8 :: Int -> Word8 96 | i2w8 n = fromIntegral n + zero 97 | 98 | ---------------------------------------------------------------- 99 | 100 | months :: ForeignPtr Word8 101 | months = let (PS p _ _) = "___JanFebMarAprMayJunJulAugSepOctNovDec" in p 102 | 103 | weekDays :: ForeignPtr Word8 104 | weekDays = let (PS p _ _) = "___MonTueWedThuFriSatSun" in p 105 | 106 | ---------------------------------------------------------------- 107 | 108 | spc :: Word8 109 | spc = 32 110 | 111 | comma :: Word8 112 | comma = 44 113 | 114 | colon :: Word8 115 | colon = 58 116 | 117 | zero :: Word8 118 | zero = 48 119 | -------------------------------------------------------------------------------- /airship/src/Airship/Internal/Decision.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ImpredicativeTypes #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | 7 | module Airship.Internal.Decision 8 | ( flow 9 | , appendRequestPath 10 | ) where 11 | 12 | import Airship.Headers (addResponseHeader) 13 | import Airship.Internal.Date (parseRfc1123Date, 14 | utcTimeToRfc1123) 15 | import Airship.Internal.Parsers (parseEtagList) 16 | import Airship.Resource (PostResponse (..), 17 | Resource (..)) 18 | import Airship.Types (Response (..), 19 | ResponseBody (..), 20 | Webmachine, addTrace, 21 | etagToByteString, 22 | getResponseBody, 23 | getResponseHeaders, halt, 24 | pathInfo, putResponseBody, 25 | request, requestHeaders, 26 | requestMethod, requestTime) 27 | #if __GLASGOW_HASKELL__ < 710 28 | import Control.Applicative ((<$>)) 29 | #endif 30 | import Control.Monad (when) 31 | import Control.Monad.Trans (lift) 32 | import Control.Monad.Trans.State.Strict (StateT (..), evalStateT, get, 33 | modify) 34 | 35 | 36 | import Blaze.ByteString.Builder (toByteString) 37 | import Data.ByteString (ByteString, intercalate) 38 | import Data.Maybe (isJust) 39 | import Data.Text (Text) 40 | import Data.Time.Clock (UTCTime) 41 | 42 | import Network.HTTP.Media 43 | import qualified Network.HTTP.Types as HTTP 44 | 45 | ------------------------------------------------------------------------------ 46 | -- HTTP Headers 47 | -- These are headers not defined for us already in 48 | -- Network.HTTP.Types 49 | ------------------------------------------------------------------------------ 50 | -- TODO this exist in http-types-0.9, see CHANGES.txt 51 | hAcceptCharset :: HTTP.HeaderName 52 | hAcceptCharset = "Accept-Charset" 53 | 54 | hAcceptEncoding :: HTTP.HeaderName 55 | hAcceptEncoding = "Accept-Encoding" 56 | 57 | hIfMatch :: HTTP.HeaderName 58 | hIfMatch = "If-Match" 59 | 60 | hIfUnmodifiedSince :: HTTP.HeaderName 61 | hIfUnmodifiedSince = "If-Unmodified-Since" 62 | 63 | hIfNoneMatch :: HTTP.HeaderName 64 | hIfNoneMatch = "If-None-Match" 65 | 66 | ------------------------------------------------------------------------------ 67 | -- FlowState: StateT used for recording information as we walk the decision 68 | -- tree 69 | ------------------------------------------------------------------------------ 70 | 71 | data FlowState m = FlowState 72 | { _contentType :: Maybe (MediaType, Webmachine m ResponseBody) } 73 | 74 | type FlowStateT m a = StateT (FlowState m) (Webmachine m) a 75 | 76 | type Flow m = Resource m -> FlowStateT m Response 77 | 78 | initFlowState :: FlowState m 79 | initFlowState = FlowState Nothing 80 | 81 | flow :: Monad m => Resource m -> Webmachine m Response 82 | flow r = evalStateT (b13 r) initFlowState 83 | 84 | trace :: Monad m => ByteString -> FlowStateT m () 85 | trace a = lift $ addTrace a 86 | 87 | ----------------------------------------------------------------------------- 88 | -- Header value data newtypes 89 | ------------------------------------------------------------------------------ 90 | 91 | newtype IfMatch = IfMatch ByteString 92 | newtype IfNoneMatch = IfNoneMatch ByteString 93 | 94 | ------------------------------------------------------------------------------ 95 | -- Decision Helpers 96 | ------------------------------------------------------------------------------ 97 | 98 | negotiateContentTypesAccepted :: Monad m => [(MediaType, Webmachine m a)] -> FlowStateT m a 99 | negotiateContentTypesAccepted accepted = do 100 | req <- lift request 101 | let reqHeaders = requestHeaders req 102 | result = do 103 | cType <- lookup HTTP.hContentType reqHeaders 104 | mapContentMedia accepted cType 105 | case result of 106 | (Just process) -> lift process 107 | Nothing -> lift $ halt HTTP.status415 108 | 109 | appendRequestPath :: Monad m => [Text] -> Webmachine m ByteString 110 | appendRequestPath ts = do 111 | currentPath <- pathInfo <$> request 112 | return $ toByteString (HTTP.encodePathSegments (currentPath ++ ts)) 113 | 114 | requestHeaderDate :: Monad m => HTTP.HeaderName -> 115 | Webmachine m (Maybe UTCTime) 116 | requestHeaderDate headerName = do 117 | req <- request 118 | let reqHeaders = requestHeaders req 119 | dateHeader = lookup headerName reqHeaders 120 | parsedDate = dateHeader >>= parseRfc1123Date 121 | return parsedDate 122 | 123 | writeCacheTags :: Monad m => Resource m -> FlowStateT m () 124 | writeCacheTags Resource{..} = lift $ do 125 | etag <- generateETag 126 | case etag of 127 | Nothing -> return () 128 | Just t -> addResponseHeader ("ETag", etagToByteString t) 129 | modified <- lastModified 130 | case modified of 131 | Nothing -> return () 132 | Just d -> addResponseHeader ("Last-Modified", utcTimeToRfc1123 d) 133 | 134 | ------------------------------------------------------------------------------ 135 | -- Type definitions for all decision nodes 136 | ------------------------------------------------------------------------------ 137 | 138 | b13, b12, b11, b10, b09, b08, b07, b06, b05, b04, b03 :: Monad m => Flow m 139 | c04, c03 :: Monad m => Flow m 140 | d05, d04 :: Monad m => Flow m 141 | e06, e05 :: Monad m => Flow m 142 | f07, f06 :: Monad m => Flow m 143 | g11, g09 :: Monad m => IfMatch -> Flow m 144 | g08, g07 :: Monad m => Flow m 145 | h12, h11, h10, h07 :: Monad m => Flow m 146 | i13 :: Monad m => IfNoneMatch -> Flow m 147 | i12, i07, i04 :: Monad m => Flow m 148 | j18 :: Monad m => Flow m 149 | k13 :: Monad m => IfNoneMatch -> Flow m 150 | k07, k05 :: Monad m => Flow m 151 | l17, l15, l14, l13, l07, l05 :: Monad m => Flow m 152 | m20, m16, m07, m05 :: Monad m => Flow m 153 | n16, n11, n05 :: Monad m => Flow m 154 | o20, o18, o17, o16, o14 :: Monad m => Flow m 155 | p11, p03 :: Monad m => Flow m 156 | 157 | ------------------------------------------------------------------------------ 158 | -- B column 159 | ------------------------------------------------------------------------------ 160 | 161 | b13 r@Resource{..} = do 162 | trace "b13" 163 | available <- lift serviceAvailable 164 | if available 165 | then b12 r 166 | else lift $ halt HTTP.status503 167 | 168 | b12 r@Resource{..} = do 169 | trace "b12" 170 | -- known method 171 | req <- lift request 172 | let knownMethods = [ HTTP.methodGet 173 | , HTTP.methodPost 174 | , HTTP.methodHead 175 | , HTTP.methodPut 176 | , HTTP.methodDelete 177 | , HTTP.methodTrace 178 | , HTTP.methodConnect 179 | , HTTP.methodOptions 180 | , HTTP.methodPatch 181 | ] 182 | if requestMethod req `elem` knownMethods 183 | then b11 r 184 | else lift $ halt HTTP.status501 185 | 186 | b11 r@Resource{..} = do 187 | trace "b11" 188 | long <- lift uriTooLong 189 | if long 190 | then lift $ halt HTTP.status414 191 | else b10 r 192 | 193 | b10 r@Resource{..} = do 194 | trace "b10" 195 | req <- lift request 196 | allowed <- lift allowedMethods 197 | if requestMethod req `elem` allowed 198 | then b09 r 199 | else do 200 | lift $ addResponseHeader ("Allow", intercalate "," allowed) 201 | lift $ halt HTTP.status405 202 | 203 | b09 r@Resource{..} = do 204 | trace "b09" 205 | malformed <- lift malformedRequest 206 | if malformed 207 | then lift $ halt HTTP.status400 208 | else b08 r 209 | 210 | b08 r@Resource{..} = do 211 | trace "b08" 212 | authorized <- lift isAuthorized 213 | if authorized 214 | then b07 r 215 | else lift $ halt HTTP.status401 216 | 217 | b07 r@Resource{..} = do 218 | trace "b07" 219 | forbid <- lift forbidden 220 | if forbid 221 | then lift $ halt HTTP.status403 222 | else b06 r 223 | 224 | b06 r@Resource{..} = do 225 | trace "b06" 226 | validC <- lift validContentHeaders 227 | if validC 228 | then b05 r 229 | else lift $ halt HTTP.status501 230 | 231 | b05 r@Resource{..} = do 232 | trace "b05" 233 | known <- lift knownContentType 234 | if known 235 | then b04 r 236 | else lift $ halt HTTP.status415 237 | 238 | b04 r@Resource{..} = do 239 | trace "b04" 240 | large <- lift entityTooLarge 241 | if large 242 | then lift $ halt HTTP.status413 243 | else b03 r 244 | 245 | b03 r@Resource{..} = do 246 | trace "b03" 247 | req <- lift request 248 | allowed <- lift allowedMethods 249 | if requestMethod req == HTTP.methodOptions 250 | then do 251 | lift $ addResponseHeader ("Allow", intercalate "," allowed) 252 | lift $ halt HTTP.status204 253 | else c03 r 254 | 255 | ------------------------------------------------------------------------------ 256 | -- C column 257 | ------------------------------------------------------------------------------ 258 | 259 | c04 r@Resource{..} = do 260 | trace "c04" 261 | req <- lift request 262 | provided <- lift contentTypesProvided 263 | let reqHeaders = requestHeaders req 264 | result = do 265 | acceptStr <- lookup HTTP.hAccept reqHeaders 266 | (acceptTyp, resource) <- mapAcceptMedia provided' acceptStr 267 | Just (acceptTyp, resource) 268 | where 269 | -- this is so that in addition to getting back the resource 270 | -- that we match, we also return the content-type provided 271 | -- by that resource. 272 | provided' = map dupContentType provided 273 | dupContentType (a, b) = (a, (a, b)) 274 | 275 | case result of 276 | Nothing -> lift $ halt HTTP.status406 277 | Just res -> do 278 | modify (\fs -> fs { _contentType = Just res }) 279 | d04 r 280 | 281 | c03 r@Resource{..} = do 282 | trace "c03" 283 | req <- lift request 284 | let reqHeaders = requestHeaders req 285 | case lookup HTTP.hAccept reqHeaders of 286 | (Just _h) -> 287 | c04 r 288 | Nothing -> 289 | d04 r 290 | 291 | ------------------------------------------------------------------------------ 292 | -- D column 293 | ------------------------------------------------------------------------------ 294 | 295 | d05 r@Resource{..} = do 296 | trace "d05" 297 | langAvailable <- lift languageAvailable 298 | if langAvailable 299 | then e05 r 300 | else lift $ halt HTTP.status406 301 | 302 | d04 r@Resource{..} = do 303 | trace "d04" 304 | req <- lift request 305 | let reqHeaders = requestHeaders req 306 | case lookup HTTP.hAcceptLanguage reqHeaders of 307 | (Just _h) -> 308 | d05 r 309 | Nothing -> 310 | e05 r 311 | 312 | ------------------------------------------------------------------------------ 313 | -- E column 314 | ------------------------------------------------------------------------------ 315 | 316 | e06 r@Resource{..} = do 317 | trace "e06" 318 | -- TODO: charset negotiation 319 | f06 r 320 | 321 | e05 r@Resource{..} = do 322 | trace "e05" 323 | req <- lift request 324 | let reqHeaders = requestHeaders req 325 | case lookup hAcceptCharset reqHeaders of 326 | (Just _h) -> 327 | e06 r 328 | Nothing -> 329 | f06 r 330 | 331 | ------------------------------------------------------------------------------ 332 | -- F column 333 | ------------------------------------------------------------------------------ 334 | 335 | f07 r@Resource{..} = do 336 | trace "f07" 337 | -- TODO: encoding negotiation 338 | g07 r 339 | 340 | f06 r@Resource{..} = do 341 | trace "f06" 342 | req <- lift request 343 | let reqHeaders = requestHeaders req 344 | case lookup hAcceptEncoding reqHeaders of 345 | (Just _h) -> 346 | f07 r 347 | Nothing -> 348 | g07 r 349 | 350 | ------------------------------------------------------------------------------ 351 | -- G column 352 | ------------------------------------------------------------------------------ 353 | 354 | g11 (IfMatch ifMatch) r@Resource{..} = do 355 | trace "g11" 356 | let etags = parseEtagList ifMatch 357 | if null etags 358 | then lift $ halt HTTP.status412 359 | else h10 r 360 | 361 | g09 ifMatch r@Resource{..} = do 362 | trace "g09" 363 | case ifMatch of 364 | -- TODO: should we be stripping whitespace here? 365 | (IfMatch "*") -> 366 | h10 r 367 | _ -> 368 | g11 ifMatch r 369 | 370 | g08 r@Resource{..} = do 371 | trace "g08" 372 | req <- lift request 373 | let reqHeaders = requestHeaders req 374 | case IfMatch <$> lookup hIfMatch reqHeaders of 375 | (Just h) -> 376 | g09 h r 377 | Nothing -> 378 | h10 r 379 | 380 | g07 r@Resource{..} = do 381 | trace "g07" 382 | -- TODO: set Vary headers 383 | exists <- lift resourceExists 384 | if exists 385 | then g08 r 386 | else h07 r 387 | 388 | ------------------------------------------------------------------------------ 389 | -- H column 390 | ------------------------------------------------------------------------------ 391 | 392 | h12 r@Resource{..} = do 393 | trace "h12" 394 | modified <- lift lastModified 395 | parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince 396 | let maybeGreater = do 397 | lastM <- modified 398 | headerDate <- parsedDate 399 | return (lastM > headerDate) 400 | if maybeGreater == Just True 401 | then lift $ halt HTTP.status412 402 | else i12 r 403 | 404 | h11 r@Resource{..} = do 405 | trace "h11" 406 | parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince 407 | if isJust parsedDate 408 | then h12 r 409 | else i12 r 410 | 411 | h10 r@Resource{..} = do 412 | trace "h10" 413 | req <- lift request 414 | let reqHeaders = requestHeaders req 415 | case lookup hIfUnmodifiedSince reqHeaders of 416 | (Just _h) -> 417 | h11 r 418 | Nothing -> 419 | i12 r 420 | 421 | h07 r@Resource {..} = do 422 | trace "h07" 423 | req <- lift request 424 | let reqHeaders = requestHeaders req 425 | case lookup hIfMatch reqHeaders of 426 | -- TODO: should we be stripping whitespace here? 427 | (Just "*") -> 428 | lift $ halt HTTP.status412 429 | _ -> 430 | i07 r 431 | 432 | ------------------------------------------------------------------------------ 433 | -- I column 434 | ------------------------------------------------------------------------------ 435 | 436 | i13 ifNoneMatch r@Resource{..} = do 437 | trace "i13" 438 | case ifNoneMatch of 439 | -- TODO: should we be stripping whitespace here? 440 | (IfNoneMatch "*") -> 441 | j18 r 442 | _ -> 443 | k13 ifNoneMatch r 444 | 445 | i12 r@Resource{..} = do 446 | trace "i12" 447 | req <- lift request 448 | let reqHeaders = requestHeaders req 449 | case IfNoneMatch <$> lookup hIfNoneMatch reqHeaders of 450 | (Just h) -> 451 | i13 h r 452 | Nothing -> 453 | l13 r 454 | 455 | i07 r = do 456 | trace "i07" 457 | req <- lift request 458 | if requestMethod req == HTTP.methodPut 459 | then i04 r 460 | else k07 r 461 | 462 | i04 r@Resource{..} = do 463 | trace "i04" 464 | moved <- lift movedPermanently 465 | case moved of 466 | (Just loc) -> do 467 | lift $ addResponseHeader ("Location", loc) 468 | lift $ halt HTTP.status301 469 | Nothing -> 470 | p03 r 471 | 472 | ------------------------------------------------------------------------------ 473 | -- J column 474 | ------------------------------------------------------------------------------ 475 | 476 | j18 _ = do 477 | trace "j18" 478 | req <- lift request 479 | let getOrHead = [ HTTP.methodGet 480 | , HTTP.methodHead 481 | ] 482 | if requestMethod req `elem` getOrHead 483 | then lift $ halt HTTP.status304 484 | else lift $ halt HTTP.status412 485 | 486 | ------------------------------------------------------------------------------ 487 | -- K column 488 | ------------------------------------------------------------------------------ 489 | 490 | k13 (IfNoneMatch ifNoneMatch) r@Resource{..} = do 491 | trace "k13" 492 | let etags = parseEtagList ifNoneMatch 493 | if null etags 494 | then l13 r 495 | else j18 r 496 | 497 | k07 r@Resource{..} = do 498 | trace "k07" 499 | prevExisted <- lift previouslyExisted 500 | if prevExisted 501 | then k05 r 502 | else l07 r 503 | 504 | k05 r@Resource{..} = do 505 | trace "k05" 506 | moved <- lift movedPermanently 507 | case moved of 508 | (Just loc) -> do 509 | lift $ addResponseHeader ("Location", loc) 510 | lift $ halt HTTP.status301 511 | Nothing -> 512 | l05 r 513 | 514 | ------------------------------------------------------------------------------ 515 | -- L column 516 | ------------------------------------------------------------------------------ 517 | 518 | l17 r@Resource{..} = do 519 | trace "l17" 520 | parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince 521 | modified <- lift lastModified 522 | let maybeGreater = do 523 | lastM <- modified 524 | ifModifiedSince <- parsedDate 525 | return (lastM > ifModifiedSince) 526 | if maybeGreater == Just True 527 | then m16 r 528 | else lift $ halt HTTP.status304 529 | 530 | l15 r@Resource{..} = do 531 | trace "l15" 532 | parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince 533 | now <- lift requestTime 534 | let maybeGreater = (> now) <$> parsedDate 535 | if maybeGreater == Just True 536 | then m16 r 537 | else l17 r 538 | 539 | l14 r@Resource{..} = do 540 | trace "l14" 541 | req <- lift request 542 | let reqHeaders = requestHeaders req 543 | dateHeader = lookup HTTP.hIfModifiedSince reqHeaders 544 | validDate = isJust (dateHeader >>= parseRfc1123Date) 545 | if validDate 546 | then l15 r 547 | else m16 r 548 | 549 | l13 r@Resource{..} = do 550 | trace "l13" 551 | req <- lift request 552 | let reqHeaders = requestHeaders req 553 | case lookup HTTP.hIfModifiedSince reqHeaders of 554 | (Just _h) -> 555 | l14 r 556 | Nothing -> 557 | m16 r 558 | 559 | l07 r = do 560 | trace "l07" 561 | req <- lift request 562 | if requestMethod req == HTTP.methodPost 563 | then m07 r 564 | else lift $ halt HTTP.status404 565 | 566 | l05 r@Resource{..} = do 567 | trace "l05" 568 | moved <- lift movedTemporarily 569 | case moved of 570 | (Just loc) -> do 571 | lift $ addResponseHeader ("Location", loc) 572 | lift $ halt HTTP.status307 573 | Nothing -> 574 | m05 r 575 | 576 | ------------------------------------------------------------------------------ 577 | -- M column 578 | ------------------------------------------------------------------------------ 579 | 580 | m20 r@Resource{..} = do 581 | trace "m20" 582 | deleteAccepted <- lift deleteResource 583 | if deleteAccepted 584 | then do 585 | completed <- lift deleteCompleted 586 | if completed 587 | then o20 r 588 | else lift $ halt HTTP.status202 589 | else lift $ halt HTTP.status500 590 | 591 | m16 r = do 592 | trace "m16" 593 | req <- lift request 594 | if requestMethod req == HTTP.methodDelete 595 | then m20 r 596 | else n16 r 597 | 598 | m07 r@Resource{..} = do 599 | trace "m07" 600 | allowMissing <- lift allowMissingPost 601 | if allowMissing 602 | then n11 r 603 | else lift $ halt HTTP.status404 604 | 605 | m05 r = do 606 | trace "m05" 607 | req <- lift request 608 | if requestMethod req == HTTP.methodPost 609 | then n05 r 610 | else lift $ halt HTTP.status410 611 | 612 | ------------------------------------------------------------------------------ 613 | -- N column 614 | ------------------------------------------------------------------------------ 615 | 616 | n16 r = do 617 | trace "n16" 618 | req <- lift request 619 | if requestMethod req == HTTP.methodPost 620 | then n11 r 621 | else o16 r 622 | 623 | n11 r@Resource{..} = trace "n11" >> lift processPost >>= flip processPostAction r 624 | 625 | create :: Monad m => [Text] -> Resource m -> FlowStateT m () 626 | create ts Resource{..} = do 627 | loc <- lift (appendRequestPath ts) 628 | lift (addResponseHeader ("Location", loc)) 629 | lift contentTypesAccepted >>= negotiateContentTypesAccepted 630 | 631 | processPostAction :: Monad m => PostResponse m -> Flow m 632 | processPostAction (PostCreate ts) r = do 633 | create ts r 634 | p11 r 635 | processPostAction (PostCreateRedirect ts) r = do 636 | create ts r 637 | lift $ halt HTTP.status303 638 | processPostAction (PostProcess accepted) r = do 639 | negotiateContentTypesAccepted accepted >> p11 r 640 | processPostAction (PostProcessRedirect accepted) _r = do 641 | locBs <- negotiateContentTypesAccepted accepted 642 | lift $ addResponseHeader ("Location", locBs) 643 | lift $ halt HTTP.status303 644 | 645 | n05 r@Resource{..} = do 646 | trace "n05" 647 | allow <- lift allowMissingPost 648 | if allow 649 | then n11 r 650 | else lift $ halt HTTP.status410 651 | 652 | ------------------------------------------------------------------------------ 653 | -- O column 654 | ------------------------------------------------------------------------------ 655 | 656 | o20 r = do 657 | trace "o20" 658 | body <- lift getResponseBody 659 | -- ResponseBody is a little tough to make an instance of 'Eq', 660 | -- so we just use a pattern match 661 | case body of 662 | Empty -> lift $ halt HTTP.status204 663 | _ -> o18 r 664 | 665 | o18 r@Resource{..} = do 666 | trace "o18" 667 | multiple <- lift multipleChoices 668 | if multiple 669 | then lift $ halt HTTP.status300 670 | else do 671 | -- TODO: set etag, expiration, etc. headers 672 | req <- lift request 673 | let getOrHead = [ HTTP.methodGet 674 | , HTTP.methodHead 675 | ] 676 | when (requestMethod req `elem` getOrHead) $ do 677 | m <- _contentType <$> get 678 | (cType, body) <- case m of 679 | Nothing -> do 680 | provided <- lift contentTypesProvided 681 | return (head provided) 682 | Just (cType, body) -> 683 | return (cType, body) 684 | b <- lift body 685 | lift $ putResponseBody b 686 | lift $ addResponseHeader ("Content-Type", renderHeader cType) 687 | writeCacheTags r 688 | lift $ halt HTTP.status200 689 | 690 | o16 r = do 691 | trace "o16" 692 | req <- lift request 693 | if requestMethod req == HTTP.methodPut 694 | then o14 r 695 | else o17 r 696 | 697 | o17 r@Resource{..} = do 698 | trace "o17" 699 | req <- lift request 700 | if requestMethod req /= HTTP.methodPatch 701 | then o18 r 702 | else lift patchContentTypesAccepted >>= negotiateContentTypesAccepted >> o20 r 703 | 704 | 705 | o14 r@Resource{..} = do 706 | trace "o14" 707 | conflict <- lift isConflict 708 | if conflict 709 | then lift $ halt HTTP.status409 710 | else lift contentTypesAccepted >>= negotiateContentTypesAccepted >> p11 r 711 | 712 | ------------------------------------------------------------------------------ 713 | -- P column 714 | ------------------------------------------------------------------------------ 715 | 716 | p11 r = do 717 | trace "p11" 718 | headers <- lift getResponseHeaders 719 | case lookup HTTP.hLocation headers of 720 | (Just _) -> 721 | lift $ halt HTTP.status201 722 | _ -> 723 | o20 r 724 | 725 | p03 r@Resource{..} = do 726 | trace "p03" 727 | conflict <- lift isConflict 728 | if conflict 729 | then lift $ halt HTTP.status409 730 | else lift contentTypesAccepted >>= negotiateContentTypesAccepted >> p11 r 731 | -------------------------------------------------------------------------------- /airship/src/Airship/Internal/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE MonoLocalBinds #-} 7 | module Airship.Internal.Helpers 8 | ( parseFormData 9 | , contentTypeMatches 10 | , redirectTemporarily 11 | , redirectPermanently 12 | , resourceToWai 13 | , resourceToWaiT 14 | , resourceToWaiT' 15 | , appendRequestPath 16 | , lookupParam 17 | , lookupParam' 18 | ) where 19 | 20 | #if __GLASGOW_HASKELL__ < 710 21 | import Control.Applicative 22 | #endif 23 | import Control.Monad (join) 24 | import Data.ByteString (ByteString, intercalate) 25 | import qualified Data.ByteString.Lazy as LB 26 | import Data.Maybe 27 | #if __GLASGOW_HASKELL__ < 710 28 | import Data.Monoid 29 | #endif 30 | import Data.Foldable (forM_) 31 | import qualified Data.HashMap.Strict as HM 32 | import qualified Data.Map.Strict as M 33 | import Data.Text (Text) 34 | import Data.Text.Encoding (decodeUtf8) 35 | import Data.Time (getCurrentTime) 36 | import Lens.Micro ((^.)) 37 | import Network.HTTP.Media 38 | import qualified Network.HTTP.Types as HTTP 39 | import qualified Network.Wai as Wai 40 | 41 | import Network.Wai.Parse 42 | import System.Random 43 | 44 | import Airship.Config 45 | import Airship.Headers 46 | import Airship.Internal.Decision 47 | import Airship.Internal.Route 48 | import Airship.Resource 49 | import Airship.Types 50 | 51 | -- | Parse form data uploaded with a @Content-Type@ of either 52 | -- @www-form-urlencoded@ or @multipart/form-data@ to return a 53 | -- list of parameter names and values and a list of uploaded 54 | -- files and their information. 55 | parseFormData :: Request -> IO ([Param], [File LB.ByteString]) 56 | parseFormData r = parseRequestBody lbsBackEnd r 57 | 58 | -- | Returns @True@ if the request's @Content-Type@ header is one of the 59 | -- provided media types. If the @Content-Type@ header is not present, 60 | -- this function will return True. 61 | contentTypeMatches :: Monad m => [MediaType] -> Webmachine m Bool 62 | contentTypeMatches validTypes = do 63 | headers <- requestHeaders <$> request 64 | let cType = lookup HTTP.hContentType headers 65 | return $ case cType of 66 | Nothing -> True 67 | Just t -> isJust $ matchContent validTypes t 68 | 69 | -- | Issue an HTTP 302 (Found) response, with `location' as the destination. 70 | redirectTemporarily :: Monad m => ByteString -> Webmachine m a 71 | redirectTemporarily location = 72 | addResponseHeader ("Location", location) >> halt HTTP.status302 73 | 74 | -- | Issue an HTTP 301 (Moved Permantently) response, 75 | -- with `location' as the destination. 76 | redirectPermanently :: Monad m => ByteString -> Webmachine m a 77 | redirectPermanently location = 78 | addResponseHeader ("Location", location) >> halt HTTP.status301 79 | 80 | toWaiResponse :: Response -> AirshipConfig -> ByteString -> ByteString -> Wai.Response 81 | toWaiResponse Response{..} cfg trace quip = 82 | case _responseBody of 83 | (ResponseBuilder b) -> 84 | Wai.responseBuilder _responseStatus headers b 85 | (ResponseFile path part) -> 86 | Wai.responseFile _responseStatus headers path part 87 | (ResponseStream streamer) -> 88 | Wai.responseStream _responseStatus headers streamer 89 | Empty -> 90 | Wai.responseBuilder _responseStatus headers mempty 91 | where 92 | headers = traced ++ quipHeader ++ _responseHeaders 93 | traced = if cfg^.includeTraceHeader == IncludeHeader 94 | then [("Airship-Trace", trace)] 95 | else [] 96 | 97 | quipHeader = if cfg^.includeQuipHeader == IncludeHeader 98 | then [("Airship-Quip", quip)] 99 | else [] 100 | 101 | -- | Given a 'RoutingSpec', a 404 resource, and a user state @s@, construct a WAI 'Application'. 102 | resourceToWai :: AirshipConfig 103 | -> RoutingSpec IO () 104 | -> ErrorResponses IO 105 | -> Wai.Application 106 | resourceToWai cfg routes errors = 107 | resourceToWaiT cfg (const id) routes errors 108 | 109 | -- | Given a 'AirshipConfig, a function to modify the 'Response' based on the 110 | -- 'AirshipRequest' and the 'Response' (like WAI middleware), a 'RoutingSpec, 111 | -- and 'ErrorResponses' construct a WAI 'Application'. 112 | resourceToWaiT :: Monad m 113 | => AirshipConfig 114 | -> (AirshipRequest -> m Wai.Response -> IO Wai.Response) 115 | -> RoutingSpec m () 116 | -> ErrorResponses m 117 | -> Wai.Application 118 | resourceToWaiT cfg run routes errors req respond = 119 | resourceToWaiT' cfg run (runRouter routes) errors req respond 120 | 121 | -- | Like 'resourceToWaiT', but expects the 'RoutingSpec' to have been 122 | -- evaluated with 'runRouter'. This is more efficient than 'resourceToWaiT', as 123 | -- the routes will not be evaluated on every request. 124 | -- 125 | -- Given @routes :: RoutingSpec IO ()@, 'resourceToWaiT'' can be invoked like so: 126 | -- 127 | -- > resourceToWaiT' cfg (const id) (runRouter routes) errors 128 | resourceToWaiT' :: Monad m 129 | => AirshipConfig 130 | -> (AirshipRequest -> m Wai.Response -> IO Wai.Response) 131 | -> Trie (RouteLeaf m) 132 | -> ErrorResponses m 133 | -> Wai.Application 134 | resourceToWaiT' cfg run routeMapping errors req respond = do 135 | let pInfo = Wai.rawPathInfo req 136 | quip <- getQuip 137 | nowTime <- getCurrentTime 138 | let (er, (reqParams, dispatched), routePath', r) = 139 | case route routeMapping pInfo of 140 | Nothing -> 141 | (errors, (mempty, []), decodeUtf8 pInfo, return $ Response HTTP.status404 [(HTTP.hContentType, "text/plain")] Empty) 142 | Just (RoutedResource rPath resource, pm) -> 143 | (M.union (errorResponses resource) errors, pm, routeText rPath, flow resource) 144 | airshipReq = AirshipRequest req routePath' 145 | requestReader = RequestReader nowTime airshipReq 146 | startingState = ResponseState [] Empty reqParams dispatched [] 147 | respond =<< run airshipReq (do 148 | (response, trace) <- 149 | eitherResponse requestReader startingState (r >>= errorResponse er) 150 | return $ toWaiResponse response cfg (traceHeader trace) quip) 151 | 152 | -- | If the Response body is Empty the response body is set based on the error responses 153 | -- provided by the application and resource. If the response body is not Empty or 154 | -- there are no error response configured for the status code in the Response then no 155 | -- action is taken. The contents of the 'Webmachine'' response body will be streamed 156 | -- back to the client. 157 | errorResponse :: Monad m => 158 | ErrorResponses m 159 | -> Response 160 | -> Webmachine m Response 161 | errorResponse errResps r@Response{..} 162 | | (HTTP.statusIsClientError _responseStatus || 163 | HTTP.statusIsServerError _responseStatus) && 164 | isResponseBodyEmpty _responseBody = do 165 | req <- request 166 | let reqHeaders = requestHeaders req 167 | acceptStr = lookup HTTP.hAccept reqHeaders 168 | errBodies = map dupContentType <$> M.lookup _responseStatus errResps 169 | mResp = join $ mapAcceptMedia <$> errBodies <*> acceptStr 170 | forM_ mResp $ \(ct, body) -> do 171 | putResponseBody =<< body 172 | addResponseHeader ("Content-Type", renderHeader ct) 173 | Response 174 | <$> return _responseStatus 175 | <*> getResponseHeaders 176 | <*> getResponseBody 177 | | otherwise = return r 178 | where 179 | isResponseBodyEmpty Empty = True 180 | isResponseBodyEmpty _ = False 181 | dupContentType (a, b) = (a, (a, b)) 182 | 183 | 184 | getQuip :: IO ByteString 185 | getQuip = do 186 | idx <- randomRIO (0, length quips - 1) 187 | return $ quips !! idx 188 | where quips = [ "never breaks eye contact" 189 | , "blame me if inappropriate" 190 | , "firm pat on the back" 191 | , "sharkfed" 192 | , "$300,000 worth of cows" 193 | , "RB_GC_GUARD" 194 | , "evacuation not done in time" 195 | , "javascript doesn't have integers" 196 | , "WARNING: ulimit -n is 1024" 197 | , "shut it down" 198 | ] 199 | 200 | traceHeader :: [ByteString] -> ByteString 201 | traceHeader = intercalate "," 202 | 203 | -- | Lookup routing parameter and return 500 Internal Server Error if not found. 204 | -- Not finding the paramter usually means the route doesn't match what 205 | -- the resource is expecting. 206 | lookupParam :: Monad m => Text -> Webmachine m Text 207 | lookupParam p = lookupParam' p >>= maybe (halt HTTP.status500) pure 208 | 209 | -- | Lookup routing parameter. 210 | lookupParam' :: Monad m => Text -> Webmachine m (Maybe Text) 211 | lookupParam' p = HM.lookup p <$> params 212 | -------------------------------------------------------------------------------- /airship/src/Airship/Internal/Parsers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Airship.Internal.Parsers 5 | ( parseEtag 6 | , parseEtagList 7 | ) where 8 | 9 | import Prelude hiding (takeWhile) 10 | 11 | #if __GLASGOW_HASKELL__ < 710 12 | import Control.Applicative ((<$>), (<|>), (*>), (<*)) 13 | #else 14 | import Control.Applicative ((<|>)) 15 | #endif 16 | import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly, sepBy', char, 17 | string, takeWhile, 18 | takeWhile1, inClass, endOfInput) 19 | import Data.ByteString (ByteString) 20 | 21 | import Airship.Types (ETag(..)) 22 | 23 | comma :: Parser Char 24 | comma = char ',' 25 | 26 | doubleQuote :: Char 27 | doubleQuote = '"' 28 | 29 | insideQuotes :: Parser a -> Parser a 30 | insideQuotes a = char doubleQuote *> a <* char doubleQuote 31 | 32 | optionalWhitespace :: Parser ByteString 33 | optionalWhitespace = takeWhile (inClass " \t") 34 | 35 | insideWhitespace :: Parser a -> Parser a 36 | insideWhitespace a = optionalWhitespace *> a <* optionalWhitespace 37 | 38 | weakETag :: Parser ETag 39 | weakETag = Weak <$> (string "W/" *> insideQuotes rest) 40 | where rest = takeWhile1 (/= doubleQuote) 41 | 42 | strongETag :: Parser ETag 43 | strongETag = insideQuotes strong 44 | where strong = Strong <$> takeWhile1 (/= doubleQuote) 45 | 46 | eTag :: Parser ETag 47 | eTag = insideWhitespace (weakETag <|> strongETag) 48 | 49 | parseEtag :: ByteString -> Maybe ETag 50 | parseEtag input = either (const Nothing) Just (parseOnly eTagToEnd input) 51 | where eTagToEnd = eTag <* endOfInput 52 | 53 | -- | Parse a list of Etags, returning an empty list if parsing fails 54 | parseEtagList :: ByteString -> [ETag] 55 | parseEtagList input = either (const []) id parseResult 56 | where parseResult = parseOnly eTagList input 57 | eTagList = (eTag `sepBy'` comma) <* endOfInput 58 | -------------------------------------------------------------------------------- /airship/src/Airship/Internal/Route.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# OPTIONS_HADDOCK hide #-} 7 | 8 | module Airship.Internal.Route 9 | ( RoutingSpec 10 | , Route 11 | , RouteLeaf 12 | , RoutedResource(..) 13 | , Trie 14 | , root 15 | , var 16 | , star 17 | , () 18 | , (#>) 19 | , (#>=) 20 | , runRouter 21 | , route 22 | , routeText 23 | ) where 24 | 25 | import Airship.Resource as Resource 26 | 27 | import Control.Monad.Writer.Class (MonadWriter, tell) 28 | import qualified Data.ByteString as B 29 | import qualified Data.ByteString.Base64 as Base64 30 | import qualified Data.ByteString.Char8 as BC8 31 | import Data.HashMap.Strict (HashMap, fromList) 32 | import qualified Data.List as L (foldl') 33 | import Data.Maybe (isNothing) 34 | import Data.Semigroup (Semigroup, (<>)) 35 | import Data.Monoid (Monoid) 36 | import Data.Text (Text) 37 | import qualified Data.Text as T (intercalate, cons) 38 | import Data.Text.Encoding (encodeUtf8, decodeUtf8) 39 | import Data.Trie (Trie) 40 | import qualified Data.Trie as Trie 41 | 42 | 43 | #if __GLASGOW_HASKELL__ < 710 44 | import Control.Applicative 45 | #endif 46 | import Control.Monad.Writer (Writer, WriterT (..), execWriter) 47 | 48 | import Data.String (IsString, fromString) 49 | 50 | -- | 'Route's represent chunks of text used to match over URLs. 51 | -- You match hardcoded paths with string literals (and the @-XOverloadedStrings@ extension), 52 | -- named variables with the 'var' combinator, and wildcards with 'star'. 53 | newtype Route = Route { getRoute :: [BoundOrUnbound] } deriving (Show, Semigroup, Monoid) 54 | 55 | routeText :: Route -> Text 56 | routeText (Route parts) = 57 | T.cons '/' $ T.intercalate "/" ((boundOrUnboundText <$> parts)) 58 | 59 | data BoundOrUnbound = Bound Text 60 | | Var Text 61 | | RestUnbound deriving (Show) 62 | 63 | 64 | boundOrUnboundText :: BoundOrUnbound -> Text 65 | boundOrUnboundText (Bound t) = t 66 | boundOrUnboundText (Var t) = ":" <> t 67 | boundOrUnboundText (RestUnbound) = "*" 68 | 69 | 70 | 71 | 72 | instance IsString Route where 73 | fromString s = Route [Bound (fromString s)] 74 | 75 | 76 | data RoutedResource m 77 | = RoutedResource Route (Resource m) 78 | 79 | 80 | data RouteLeaf m = RouteMatch (RoutedResource m) [Text] 81 | | RVar 82 | | RouteMatchOrVar (RoutedResource m) [Text] 83 | | Wildcard (RoutedResource m) 84 | 85 | 86 | -- | Turns the list of routes in a 'RoutingSpec' into a 'Trie' for efficient 87 | -- routing 88 | runRouter :: RoutingSpec m a -> Trie (RouteLeaf m) 89 | runRouter routes = toTrie $ execWriter (getRouter routes) 90 | where 91 | -- Custom version of Trie.fromList that resolves key conflicts 92 | -- in the desired manner. In the case of duplicate routes the 93 | -- routes specified first are favored over any subsequent 94 | -- specifications. 95 | toTrie = L.foldl' insertOrReplace Trie.empty 96 | insertOrReplace t (k, v) = 97 | let newV = maybe v (mergeValues v) $ Trie.lookup k t 98 | in Trie.insert k newV t 99 | mergeValues (Wildcard x) _ = Wildcard x 100 | mergeValues _ (Wildcard x) = Wildcard x 101 | mergeValues RVar RVar = RVar 102 | mergeValues RVar (RouteMatch x y) = RouteMatchOrVar x y 103 | mergeValues (RouteMatch _ _) (RouteMatch x y) = RouteMatch x y 104 | mergeValues (RouteMatch x y) RVar = RouteMatchOrVar x y 105 | mergeValues (RouteMatchOrVar _ _) (RouteMatch x y) = RouteMatchOrVar x y 106 | mergeValues (RouteMatchOrVar x y) _ = RouteMatchOrVar x y 107 | mergeValues _ v = v 108 | 109 | -- | @a '' b@ separates the path components @a@ and @b@ with a slash. 110 | -- This is actually just a synonym for 'mappend'. 111 | () :: Route -> Route -> Route 112 | () = (<>) 113 | 114 | -- | Represents the root resource (@/@). This should usually be the first path declared in a 'RoutingSpec'. 115 | root :: Route 116 | root = Route [] 117 | 118 | -- | Captures a named in a route and adds it to the 'routingParams' hashmap under the provided 'Text' value. For example, 119 | -- 120 | -- @ 121 | -- "blog" '' 'var' "date" '' 'var' "post" 122 | -- @ 123 | -- 124 | -- will capture all URLs of the form @\/blog\/$date\/$post@, and add @date@ and @post@ to the 'routingParams' 125 | -- contained within the resource this route maps to. 126 | var :: Text -> Route 127 | var t = Route [Var t] 128 | 129 | -- | Captures a wildcard route. For example, 130 | -- 131 | -- @ 132 | -- "emcees" '' star 133 | -- @ 134 | -- 135 | -- will match @\/emcees@, @\/emcees/biggie@, @\/emcees\/earl\/vince@, and so on and so forth. 136 | star :: Route 137 | star = Route [RestUnbound] 138 | 139 | 140 | -- Routing trie creation algorithm 141 | -- 1. Store full paths as keys up to first `var` 142 | -- 2. Calculate Base64 encoding of the URL portion preceding the 143 | -- `var` ++ "var" and use that as key for the next part of the 144 | -- route spec. 145 | -- 3. Repeat step 2 for every `var` encountered until the route 146 | -- is completed and maps to a resource. 147 | (#>) :: MonadWriter [(B.ByteString, (RouteLeaf a))] m 148 | => Route -> Resource a -> m () 149 | k #> v = do 150 | let (key, routes, vars, isWild) = foldl routeFoldFun ("", [], [], False) (getRoute k) 151 | key' = if BC8.null key then "/" 152 | else key 153 | ctor = if isWild 154 | then Wildcard (RoutedResource k v) 155 | else RouteMatch (RoutedResource k v) vars 156 | tell $ (key', ctor) : routes 157 | where 158 | routeFoldFun (kps, rt, vs, False) (Bound x) = 159 | (B.concat [kps, "/", encodeUtf8 x], rt, vs, False) 160 | routeFoldFun (kps, rt, vs, False) (Var x) = 161 | let partKey = Base64.encode $ B.concat [kps, "var"] 162 | rt' = (kps, RVar) : rt 163 | in (partKey, rt', x:vs, False) 164 | routeFoldFun (kps, rt, vs, False) RestUnbound = 165 | (kps, rt, vs, True) 166 | routeFoldFun (kps, rt, vs, True) _ = 167 | (kps, rt, vs, True) 168 | 169 | 170 | (#>=) :: MonadWriter [(B.ByteString, (RouteLeaf a))] m 171 | => Route -> m (Resource a) -> m () 172 | k #>= mv = mv >>= (k #>) 173 | 174 | 175 | -- | Represents a fully-specified set of routes that map paths (represented as 'Route's) to 'Resource's. 'RoutingSpec's are declared with do-notation, to wit: 176 | -- 177 | -- @ 178 | -- myRoutes :: RoutingSpec IO () 179 | -- myRoutes = do 180 | -- root #> myRootResource 181 | -- "blog" '' var "date" '' var "post" #> blogPostResource 182 | -- "about" #> aboutResource 183 | -- "anything" '' star #> wildcardResource 184 | -- @ 185 | -- 186 | newtype RoutingSpec m a = RoutingSpec { 187 | getRouter :: Writer [(B.ByteString, RouteLeaf m)] a 188 | } deriving ( Functor, Applicative, Monad 189 | , MonadWriter [(B.ByteString, RouteLeaf m)] 190 | ) 191 | 192 | 193 | route :: Trie (RouteLeaf a) 194 | -> BC8.ByteString 195 | -> Maybe (RoutedResource a, (HashMap Text Text, [Text])) 196 | route routes pInfo = let matchRes = Trie.match routes pInfo 197 | in matchRoute' routes matchRes mempty Nothing 198 | 199 | 200 | matchRoute' :: Trie (RouteLeaf a) 201 | -> Maybe (B.ByteString, RouteLeaf a, B.ByteString) 202 | -> [Text] 203 | -> Maybe B.ByteString 204 | -> Maybe (RoutedResource a, (HashMap Text Text, [Text])) 205 | matchRoute' _routes Nothing _ps _dsp = 206 | -- Nothing even partially matched the route 207 | Nothing 208 | matchRoute' routes (Just (matched, RouteMatchOrVar r vars, "")) ps dsp = 209 | -- The matched key is also a prefix of other routes, but the 210 | -- entire path matched so handle like a RouteMatch. 211 | matchRoute' routes (Just (matched, RouteMatch r vars, "")) ps dsp 212 | matchRoute' _routes (Just (matched, RouteMatch r vars, "")) ps dsp = 213 | -- The entire path matched so return the resource, params, and 214 | -- dispatch path 215 | Just (r, (fromList $ zip vars ps, dispatchList dsp matched)) 216 | where 217 | dispatchList (Just d) m = toTextList $ B.concat [d, m] 218 | dispatchList Nothing _ = mempty 219 | toTextList bs = decodeUtf8 <$> BC8.split '/' bs 220 | matchRoute' _routes (Just (_matched, RouteMatch _r _vars, _)) _ps _dsp = 221 | -- Part of the request path matched, but the trie value at the 222 | -- matched prefix is not an RVar or RouteMatchOrVar so there is no 223 | -- match. 224 | Nothing 225 | matchRoute' routes (Just (matched, RouteMatchOrVar _r _vars, rest)) ps dsp = 226 | -- Part of the request path matched and the trie value at the 227 | -- matched prefix is a RouteMatchOrVar so handle it the same as if 228 | -- the value were RVar. 229 | matchRoute' routes (Just (matched, RVar, rest)) ps dsp 230 | matchRoute' routes (Just (matched, RVar, rest)) ps dsp 231 | | BC8.null rest = Nothing 232 | | BC8.take 2 rest == "//" = Nothing 233 | | BC8.head rest == '/' = 234 | -- Part of the request path matched and the trie value at the 235 | -- matched prefix is a RVar so calculate the key for the next part 236 | -- of the route and continue attempting to match. 237 | let nextKey = B.concat [ Base64.encode $ B.concat [matched, "var"] 238 | , BC8.dropWhile (/='/') $ BC8.dropWhile (=='/') rest 239 | ] 240 | updDsp = if isNothing dsp then Just mempty 241 | else dsp 242 | paramVal = decodeUtf8 . BC8.takeWhile (/='/') 243 | $ BC8.dropWhile (=='/') rest 244 | matchRes = Trie.match routes nextKey 245 | in matchRoute' routes matchRes (paramVal:ps) updDsp 246 | | otherwise = Nothing 247 | matchRoute' _routes (Just (_matched, Wildcard r, rest)) _ps _dsp = 248 | -- Encountered a wildcard (star) value in the trie so it's a match 249 | Just (r, (mempty, decodeUtf8 <$> [BC8.dropWhile (=='/') rest])) 250 | -------------------------------------------------------------------------------- /airship/src/Airship/RST.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This file is copyright (c) 2009, the Snap Framework authors, 3 | and Patrick Thomson (for the Airship project). 4 | Used under the three-clause BSD license, the text of which may be 5 | found in the LICENSE file in the Airship root. 6 | -} 7 | 8 | {-# LANGUAGE BangPatterns #-} 9 | {-# LANGUAGE CPP #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | {- 16 | RST is like the RWST monad, but has no Writer instance, as Writer leaks space. 17 | This file is almost entirely lifted from the Snap framework's implementation. 18 | -} 19 | 20 | module Airship.RST 21 | ( RST (..) 22 | , evalRST 23 | , execRST 24 | , mapRST 25 | , withRST 26 | , failure 27 | ) where 28 | 29 | import Control.Applicative (Alternative (..), 30 | Applicative (..)) 31 | import Control.Category ((.)) 32 | import Control.Monad (MonadPlus (..), ap) 33 | import Control.Monad.Base (MonadBase (..)) 34 | import Control.Monad.Reader (MonadReader (..)) 35 | import Control.Monad.State.Class (MonadState (..)) 36 | import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) 37 | import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), 38 | MonadTransControl (..), 39 | defaultLiftBaseWith, 40 | defaultRestoreM) 41 | import Data.Either 42 | import Prelude (Functor (..), Monad (..), seq, 43 | ($), ($!)) 44 | 45 | 46 | newtype RST r s e m a = RST { runRST :: r -> s -> m (Either e a, s) } 47 | 48 | 49 | evalRST :: Monad m => RST r s e m a -> r -> s -> m (Either e a) 50 | evalRST m r s = do 51 | (res, _) <- runRST m r s 52 | return $! res 53 | {-# INLINE evalRST #-} 54 | 55 | 56 | execRST :: Monad m => RST r s e m a -> r -> s -> m s 57 | execRST m r s = do 58 | (_,!s') <- runRST m r s 59 | return $! s' 60 | {-# INLINE execRST #-} 61 | 62 | 63 | withRST :: Monad m => (r' -> r) -> RST r s e m a -> RST r' s e m a 64 | withRST f m = RST $ \r' s -> runRST m (f r') s 65 | {-# INLINE withRST #-} 66 | 67 | 68 | instance (Monad m) => MonadReader r (RST r s e m) where 69 | ask = RST $ \r s -> return $! (Right r,s) 70 | local f m = RST $ \r s -> runRST m (f r) s 71 | 72 | instance (Functor m) => Functor (RST r s e m) where 73 | fmap f m = RST $ \r s -> fmap (\(a,s') -> (fmap f a, s')) $ runRST m r s 74 | 75 | instance Monad m => Applicative (RST r s e m) where 76 | pure = return 77 | (<*>) = ap 78 | 79 | 80 | instance MonadPlus m => Alternative (RST r s e m) where 81 | empty = mzero 82 | (<|>) = mplus 83 | 84 | 85 | instance (Monad m) => MonadState s (RST r s e m) where 86 | get = RST $ \_ s -> return $! (Right s,s) 87 | put x = RST $ \_ _ -> return $! (Right (),x) 88 | state act = RST $ \_ s -> do 89 | let (res, !s') = act s 90 | return $! (Right res, s') 91 | 92 | 93 | mapRST :: (m (Either e a, s) -> n (Either e b, s)) -> RST r s e m a -> RST r s e n b 94 | mapRST f m = RST $ \r s -> f (runRST m r s) 95 | 96 | rwsBind :: Monad m => 97 | RST r s e m a 98 | -> (a -> RST r s e m b) 99 | -> RST r s e m b 100 | rwsBind m f = RST go 101 | where 102 | go r !s = do 103 | (a, !s') <- runRST m r s 104 | case a of 105 | Left e -> return $! (Left e, s') 106 | Right a' -> runRST (f a') r s' 107 | {-# INLINE rwsBind #-} 108 | 109 | instance (Monad m) => Monad (RST r s e m) where 110 | return a = RST $ \_ s -> return $! (Right a, s) 111 | (>>=) = rwsBind 112 | -- fail msg = RST $ \_ _ -> fail msg 113 | 114 | instance (MonadPlus m) => MonadPlus (RST r s e m) where 115 | mzero = RST $ \_ _ -> mzero 116 | m `mplus` n = RST $ \r s -> runRST m r s `mplus` runRST n r s 117 | 118 | 119 | instance (MonadIO m) => MonadIO (RST r s e m) where 120 | liftIO = lift . liftIO 121 | 122 | 123 | instance MonadTrans (RST r s e) where 124 | lift m = RST $ \_ s -> do 125 | a <- m 126 | return $ s `seq` (Right a, s) 127 | 128 | 129 | instance MonadBase b m => MonadBase b (RST r s e m) where 130 | liftBase = lift . liftBase 131 | 132 | 133 | instance MonadBaseControl b m => MonadBaseControl b (RST r s e m) where 134 | type StM (RST r s e m) a = ComposeSt (RST r s e) m a 135 | liftBaseWith = defaultLiftBaseWith 136 | restoreM = defaultRestoreM 137 | {-# INLINE liftBaseWith #-} 138 | {-# INLINE restoreM #-} 139 | 140 | instance MonadTransControl (RST r s e) where 141 | type StT (RST r s e) a = (Either e a, s) 142 | liftWith f = RST $ \r s -> do 143 | res <- f $ \(RST g) -> g r s 144 | return $! (Right res, s) 145 | restoreT k = RST $ \_ _ -> k 146 | {-# INLINE liftWith #-} 147 | {-# INLINE restoreT #-} 148 | 149 | failure :: Monad m => e -> RST r s e m a 150 | failure e = RST $ \_ s -> return $! (Left e, s) 151 | -------------------------------------------------------------------------------- /airship/src/Airship/Resource.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | module Airship.Resource 8 | ( Resource(..) 9 | , PostResponse(..) 10 | , serverError 11 | , defaultResource 12 | ) where 13 | 14 | import Airship.Types 15 | 16 | import Data.ByteString (ByteString) 17 | #if __GLASGOW_HASKELL__ < 710 18 | import Data.Monoid (mappend, mempty) 19 | #endif 20 | import Data.Text (Text) 21 | import Data.Time.Clock (UTCTime) 22 | import Network.HTTP.Media (MediaType) 23 | import Network.HTTP.Types 24 | 25 | -- | Used when processing POST requests so as to handle the outcome of the binary decisions between 26 | -- handling a POST as a create request and whether to redirect after the POST is done. 27 | -- Credit for this idea goes to Richard Wallace (purefn) on Webcrank. 28 | -- 29 | -- For processing the POST, an association list of 'MediaType's and 'Webmachine' actions are required 30 | -- that correspond to the accepted @Content-Type@ values that this resource can accept in a request body. 31 | -- If a @Content-Type@ header is present but not accounted for, processing will halt with 32 | -- @415 Unsupported Media Type@. 33 | data PostResponse m 34 | = PostCreate [Text] -- ^ Treat this request as a PUT. 35 | | PostCreateRedirect [Text] -- ^ Treat this request as a PUT, then redirect. 36 | | PostProcess [(MediaType, Webmachine m ())] -- ^ Process as a POST, but don't redirect. 37 | | PostProcessRedirect [(MediaType, Webmachine m ByteString)] -- ^ Process and redirect. 38 | 39 | data Resource m = 40 | Resource { -- | Whether to allow HTTP POSTs to a missing resource. Default: false. 41 | allowMissingPost :: Webmachine m Bool 42 | -- | The set of HTTP methods that this resource allows. Default: @GET@ and @HEAD@. 43 | -- If a request arrives with an HTTP method not included herein, @501 Not Implemented@ is returned. 44 | , allowedMethods :: Webmachine m [Method] 45 | -- | An association list of 'MediaType's and 'Webmachine' actions that correspond to the accepted 46 | -- @Content-Type@ values that this resource can accept in a request body. If a @Content-Type@ header 47 | -- is present but not accounted for in 'contentTypesAccepted', processing will halt with @415 Unsupported Media Type@. 48 | -- Otherwise, the corresponding 'Webmachine' action will be executed and processing will continue. 49 | , contentTypesAccepted :: Webmachine m [(MediaType, Webmachine m ())] 50 | -- | An association list of 'MediaType' values and 'ResponseBody' values. The response will be chosen 51 | -- by looking up the 'MediaType' that most closely matches the @Accept@ header. Should there be no match, 52 | -- processing will halt with @406 Not Acceptable@. 53 | , contentTypesProvided :: Webmachine m [(MediaType, Webmachine m ResponseBody)] 54 | -- | When a @DELETE@ request is enacted (via a @True@ value returned from 'deleteResource'), a 55 | -- @False@ value returns a @202 Accepted@ response. Returning @True@ will continue processing, 56 | -- usually ending up with a @204 No Content@ response. Default: False. 57 | , deleteCompleted :: Webmachine m Bool 58 | -- | When processing a @DELETE@ request, a @True@ value allows processing to continue. 59 | -- Returns @500 Forbidden@ if False. Default: false. 60 | , deleteResource :: Webmachine m Bool 61 | -- | Returns @413 Request Entity Too Large@ if true. Default: false. 62 | , entityTooLarge :: Webmachine m Bool 63 | -- | Checks if the given request is allowed to access this resource. 64 | -- Returns @403 Forbidden@ if true. Default: false. 65 | , forbidden :: Webmachine m Bool 66 | -- | If this returns a non-'Nothing' 'ETag', its value will be added to every HTTP response 67 | -- in the @ETag:@ field. 68 | , generateETag :: Webmachine m (Maybe ETag) 69 | -- | Checks if this resource has actually implemented a handler for a given HTTP method. 70 | -- Returns @501 Not Implemented@ if false. Default: true. 71 | , implemented :: Webmachine m Bool 72 | -- | Returns @401 Unauthorized@ if false. Default: true. 73 | , isAuthorized :: Webmachine m Bool 74 | -- | When processing @PUT@ requests, a @True@ value returned here will halt processing with a @409 Conflict@. 75 | , isConflict :: Webmachine m Bool 76 | -- | Returns @415 Unsupported Media Type@ if false. We recommend you use the 'contentTypeMatches' helper function, which accepts a list of 77 | -- 'MediaType' values, so as to simplify proper MIME type handling. Default: true. 78 | , knownContentType :: Webmachine m Bool 79 | -- | In the presence of an @If-Modified-Since@ header, returning a @Just@ value from 'lastModifed' allows 80 | -- the server to halt with @304 Not Modified@ if appropriate. 81 | , lastModified :: Webmachine m (Maybe UTCTime) 82 | -- | If an @Accept-Language@ value is present in the HTTP request, and this function returns @False@, 83 | -- processing will halt with @406 Not Acceptable@. 84 | , languageAvailable :: Webmachine m Bool 85 | -- | Returns @400 Bad Request@ if true. Default: false. 86 | , malformedRequest :: Webmachine m Bool 87 | -- wondering if this should be text, 88 | -- or some 'path' type 89 | -- | When processing a resource for which 'resourceExists' returned @False@, returning a @Just@ value 90 | -- halts with a @301 Moved Permanently@ response. The contained 'ByteString' will be added to the 91 | -- HTTP response under the @Location:@ header. 92 | , movedPermanently :: Webmachine m (Maybe ByteString) 93 | -- | Like 'movedPermanently', except with a @307 Moved Temporarily@ response. 94 | , movedTemporarily :: Webmachine m (Maybe ByteString) 95 | -- | When handling a @PUT@ request, returning @True@ here halts processing with @300 Multiple Choices@. Default: False. 96 | , multipleChoices :: Webmachine m Bool 97 | -- | As 'contentTypesAccepted', but checked and executed specifically in the case of a PATCH request. 98 | , patchContentTypesAccepted :: Webmachine m [(MediaType, Webmachine m ())] 99 | -- | When processing a request for which 'resourceExists' returned @False@, returning @True@ here 100 | -- allows the 'movedPermanently' and 'movedTemporarily' functions to process the request. 101 | , previouslyExisted :: Webmachine m Bool 102 | -- | When handling @POST@ requests, the value returned determines whether to treat the request as a @PUT@, 103 | -- a @PUT@ and a redirect, or a plain @POST@. See the documentation for 'PostResponse' for more information. 104 | -- The default implemetation returns a 'PostProcess' with an empty handler. 105 | , processPost :: Webmachine m (PostResponse m) 106 | -- | Does the resource at this path exist? 107 | -- Returning false from this usually entails a @404 Not Found@ response. 108 | -- (If 'allowMissingPost' returns @True@ or an @If-Match: *@ header is present, it may not). 109 | , resourceExists :: Webmachine m Bool 110 | -- | Returns @503 Service Unavailable@ if false. Default: true. 111 | , serviceAvailable :: Webmachine m Bool 112 | -- | Returns @414 Request URI Too Long@ if true. Default: false. 113 | , uriTooLong :: Webmachine m Bool 114 | -- | Returns @501 Not Implemented@ if false. Default: true. 115 | , validContentHeaders :: Webmachine m Bool 116 | , errorResponses :: ErrorResponses m 117 | } 118 | 119 | 120 | -- | A helper function that terminates execution with @500 Internal Server Error@. 121 | serverError :: Monad m => Webmachine m a 122 | serverError = finishWith (Response status500 [] Empty) 123 | 124 | -- | The default Airship resource, with "sensible" values filled in for each entry. 125 | -- You construct new resources by extending the default resource with your own handlers. 126 | defaultResource :: Monad m => Resource m 127 | defaultResource = Resource { allowMissingPost = return False 128 | , allowedMethods = return [methodOptions, methodGet, methodHead] 129 | , contentTypesAccepted = return [] 130 | , contentTypesProvided = return [("text/html", halt status405)] 131 | , deleteCompleted = return False 132 | , deleteResource = return False 133 | , entityTooLarge = return False 134 | , forbidden = return False 135 | , generateETag = return Nothing 136 | , implemented = return True 137 | , isAuthorized = return True 138 | , isConflict = return False 139 | , knownContentType = return True 140 | , lastModified = return Nothing 141 | , languageAvailable = return True 142 | , malformedRequest = return False 143 | , movedPermanently = return Nothing 144 | , movedTemporarily = return Nothing 145 | , multipleChoices = return False 146 | , patchContentTypesAccepted = return [] 147 | , previouslyExisted = return False 148 | , processPost = return (PostProcess []) 149 | , resourceExists = return True 150 | , serviceAvailable = return True 151 | , uriTooLong = return False 152 | , validContentHeaders = return True 153 | , errorResponses = mempty 154 | } 155 | -------------------------------------------------------------------------------- /airship/src/Airship/Resource/Static.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | 6 | module Airship.Resource.Static 7 | ( FileInfo(..) 8 | , StaticOptions(..) 9 | , staticResource 10 | , allFilesAtRoot 11 | , epochToUTCTime 12 | , directoryTree 13 | ) where 14 | 15 | #if __GLASGOW_HASKELL__ < 710 16 | import Control.Applicative ((<$>)) 17 | #endif 18 | 19 | import Airship.Headers (addResponseHeader) 20 | import Airship.Types ( ETag(Strong) 21 | , ResponseBody(ResponseFile) 22 | , Webmachine 23 | , dispatchPath 24 | , halt 25 | ) 26 | import Airship.Resource (Resource(..), defaultResource) 27 | 28 | 29 | import Control.Monad (foldM, when) 30 | import qualified Crypto.Hash.MD5 as MD5 31 | import Data.ByteString (ByteString) 32 | import qualified Data.ByteString as BS 33 | import qualified Data.ByteString.Base64.URL as Base64URL 34 | import Data.ByteString.Char8 (pack, split) 35 | import Data.Monoid ((<>)) 36 | import qualified Data.Text as T 37 | import Data.Text.Encoding (encodeUtf8) 38 | import Data.Time.Clock (UTCTime) 39 | import Data.Time.Clock.POSIX (posixSecondsToUTCTime) 40 | import qualified Data.Trie as Trie 41 | import Network.HTTP.Media ((//)) 42 | import qualified Network.HTTP.Types as HTTP 43 | import qualified Network.Mime as Mime 44 | import qualified System.Directory as D 45 | import System.FilePath (takeFileName) 46 | import qualified System.Posix.Files as Files 47 | import System.IO (IOMode(ReadMode), withBinaryFile) 48 | import System.Posix.Types (EpochTime) 49 | 50 | 51 | data FileTree = FileTree { tree :: Trie.Trie FileInfo 52 | , root :: T.Text 53 | } 54 | 55 | data FileInfo = FileInfo 56 | { _path :: FilePath 57 | , _size :: Integer 58 | , _lastModified :: UTCTime 59 | , _etag :: ETag 60 | } deriving (Show, Eq, Ord) 61 | 62 | data StaticOptions = Cache | NoCache deriving (Eq) 63 | 64 | epochToUTCTime :: EpochTime -> UTCTime 65 | epochToUTCTime = posixSecondsToUTCTime . realToFrac 66 | 67 | fileETag :: FilePath -> IO ETag 68 | fileETag p = withBinaryFile p ReadMode makeEtag 69 | where makeEtag h = do 70 | let ctx = MD5.init 71 | res <- go ctx h 72 | return (Strong (BS.take 22 (Base64URL.encode (MD5.finalize res)))) 73 | go ctx h = do 74 | bs <- BS.hGetSome h 1024 75 | if BS.null bs 76 | then return ctx 77 | else return (MD5.update ctx bs) 78 | 79 | 80 | filteredDirectory :: FilePath -> IO [FilePath] 81 | filteredDirectory p = filter (not . (`elem` [".", ".."])) <$> D.getDirectoryContents p 82 | 83 | allFilesAtRoot :: FilePath -> IO [FilePath] 84 | allFilesAtRoot p = filteredDirectory p >>= foldM folder [] 85 | where folder :: [FilePath] -> FilePath -> IO [FilePath] 86 | folder acc f = do 87 | let fullPath = p <> "/" <> f 88 | exists <- D.doesDirectoryExist fullPath 89 | if exists 90 | then do 91 | more <- allFilesAtRoot (p <> "/" <> f) 92 | return (more ++ acc) 93 | else return (fullPath : acc) 94 | 95 | regularFileStatus :: [FilePath] -> IO [(FilePath, Files.FileStatus)] 96 | regularFileStatus fs = filter (Files.isRegularFile . snd) <$> 97 | mapM (\f -> (,) f <$> Files.getFileStatus f) fs 98 | 99 | fileInfos :: [(FilePath, Files.FileStatus, ETag)] -> [(ByteString, FileInfo)] 100 | fileInfos = map (\(p, s, e) -> (pack p, statusToInfo p s e)) 101 | 102 | statusToInfo :: FilePath -> Files.FileStatus -> ETag -> FileInfo 103 | statusToInfo p i e = FileInfo { _path = p 104 | , _size = fromIntegral (Files.fileSize i) 105 | , _lastModified = epochToUTCTime (Files.modificationTime i) 106 | , _etag = e 107 | } 108 | 109 | directoryTree :: FilePath -> IO FileTree 110 | directoryTree f = do 111 | regularFiles <- allFilesAtRoot f >>= regularFileStatus 112 | etags <- mapM (fileETag . fst) regularFiles 113 | let infos = fileInfos (zipWith (\(a,b) c -> (a,b,c)) regularFiles etags) 114 | return (FileTree (Trie.fromList infos) (T.pack f)) 115 | 116 | staticResource :: Monad m => StaticOptions -> FilePath -> IO (Resource m) 117 | staticResource options p = staticResource' options <$> directoryTree p 118 | 119 | staticResource' :: Monad m => StaticOptions -> FileTree -> Resource m 120 | staticResource' options FileTree{..} = defaultResource 121 | { allowedMethods = return [ HTTP.methodGet, HTTP.methodHead ] 122 | , resourceExists = getFileInfo >> return True 123 | , generateETag = if options == Cache 124 | then Just . _etag <$> getFileInfo 125 | else return Nothing 126 | , lastModified = if options == Cache 127 | then Just . _lastModified <$> getFileInfo 128 | else return Nothing 129 | , contentTypesProvided = do 130 | fInfo <- getFileInfo 131 | when (options == NoCache) addNoCacheHeaders 132 | let response = return (ResponseFile (_path fInfo) Nothing) 133 | fileName = T.pack (takeFileName (_path fInfo)) 134 | fromExtension = Mime.defaultMimeLookup fileName 135 | (a:b:_tl) = split '/' fromExtension 136 | mediaType = a // b 137 | return [ (mediaType, response) 138 | , ("application/octet-stream", response)] 139 | } 140 | where getFileInfo :: Monad m => Webmachine m FileInfo 141 | getFileInfo = do 142 | dispath <- dispatchPath 143 | let key = encodeUtf8 (T.intercalate "/" (root:dispath)) 144 | let res = Trie.lookup key tree 145 | case res of 146 | (Just r) -> return r 147 | Nothing -> halt HTTP.status404 148 | 149 | addNoCacheHeaders :: Monad m => Webmachine m () 150 | addNoCacheHeaders = do 151 | addResponseHeader (HTTP.hCacheControl, "no-cache, no-store, must-revalidate") 152 | addResponseHeader ("Pragma", "no-cache") 153 | addResponseHeader ("Expires", "0") 154 | -------------------------------------------------------------------------------- /airship/src/Airship/Route.hs: -------------------------------------------------------------------------------- 1 | module Airship.Route 2 | ( Route 3 | , RoutingSpec 4 | , RouteLeaf 5 | , Trie 6 | , root 7 | , var 8 | , star 9 | , () 10 | , (#>) 11 | , (#>=) 12 | , runRouter 13 | ) where 14 | 15 | import Airship.Internal.Route 16 | -------------------------------------------------------------------------------- /airship/src/Airship/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE ImpredicativeTypes #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | module Airship.Types 14 | ( ETag(..) 15 | , Webmachine 16 | , AirshipRequest(..) 17 | , Request(..) 18 | , RequestReader(..) 19 | , Response(..) 20 | , ResponseState(..) 21 | , ResponseBody(..) 22 | , ErrorResponses 23 | , addTrace 24 | , defaultRequest 25 | , entireRequestBody 26 | , etagToByteString 27 | , eitherResponse 28 | , escapedResponse 29 | , mapWebmachine 30 | , runWebmachine 31 | , request 32 | , requestTime 33 | , routePath 34 | , getResponseHeaders 35 | , getResponseBody 36 | , params 37 | , dispatchPath 38 | , putResponseBody 39 | , putResponseBS 40 | , halt 41 | , finishWith 42 | ) where 43 | 44 | import Airship.RST 45 | import Blaze.ByteString.Builder (Builder) 46 | import Blaze.ByteString.Builder.ByteString (fromByteString) 47 | import Blaze.ByteString.Builder.Html.Utf8 (fromHtmlEscapedText) 48 | import qualified Data.ByteString as BS 49 | import qualified Data.ByteString.Lazy as LB 50 | #if __GLASGOW_HASKELL__ < 710 51 | import Control.Applicative 52 | #endif 53 | import Control.Monad (liftM) 54 | import Control.Monad.Base (MonadBase) 55 | import Control.Monad.IO.Class (MonadIO, liftIO) 56 | import Control.Monad.Morph 57 | import Control.Monad.Reader.Class (MonadReader, ask) 58 | import Control.Monad.State.Class 59 | import Control.Monad.Trans.Control (MonadBaseControl (..)) 60 | import Data.ByteString.Char8 hiding (reverse) 61 | import Data.HashMap.Strict (HashMap) 62 | import Data.Map.Strict (Map) 63 | import Data.Monoid ((<>)) 64 | import Data.Text (Text) 65 | import Data.Time.Clock (UTCTime) 66 | import Network.HTTP.Media 67 | import qualified Network.HTTP.Types as HTTP 68 | 69 | import Network.HTTP.Types (ResponseHeaders, Status) 70 | 71 | import Network.Wai (Request (..), 72 | defaultRequest) 73 | import qualified Network.Wai as Wai 74 | 75 | -- | Reads the entirety of the request body in a single string. 76 | -- This turns the chunks obtained from repeated invocations of 'requestBody' into a lazy 'ByteString'. 77 | entireRequestBody :: MonadIO m => Request -> m LB.ByteString 78 | entireRequestBody req = liftIO (requestBody req) >>= strictRequestBody' LB.empty 79 | where strictRequestBody' acc prev 80 | | BS.null prev = return acc 81 | | otherwise = liftIO (requestBody req) >>= strictRequestBody' (acc <> LB.fromStrict prev) 82 | 83 | data RequestReader = RequestReader 84 | { _now :: UTCTime 85 | , _airshipRequest :: AirshipRequest 86 | } 87 | 88 | data AirshipRequest = AirshipRequest 89 | { _request :: Request 90 | , _routePath :: Text 91 | } 92 | 93 | data ETag = Strong ByteString 94 | | Weak ByteString 95 | deriving (Eq, Ord) 96 | 97 | instance Show ETag where show = unpack . etagToByteString 98 | 99 | etagToByteString :: ETag -> ByteString 100 | etagToByteString (Strong bs) = "\"" <> bs <> "\"" 101 | etagToByteString (Weak bs) = "W/\"" <> bs <> "\"" 102 | 103 | -- | Basically Wai's unexported 'Response' type. 104 | data ResponseBody 105 | = ResponseFile FilePath (Maybe Wai.FilePart) 106 | | ResponseBuilder Builder 107 | | ResponseStream Wai.StreamingBody 108 | | Empty 109 | -- ResponseRaw ... (not implemented yet, but useful for websocket upgrades) 110 | 111 | -- | Helper function for building a `ResponseBuilder` out of HTML-escaped text. 112 | escapedResponse :: Text -> ResponseBody 113 | escapedResponse = ResponseBuilder . fromHtmlEscapedText 114 | 115 | data Response = Response { _responseStatus :: Status 116 | , _responseHeaders :: ResponseHeaders 117 | , _responseBody :: ResponseBody 118 | } 119 | 120 | data ResponseState = ResponseState { stateHeaders :: ResponseHeaders 121 | , stateBody :: ResponseBody 122 | , _params :: HashMap Text Text 123 | , _dispatchPath :: [Text] 124 | , decisionTrace :: Trace 125 | } 126 | 127 | type Trace = [ByteString] 128 | 129 | type ErrorResponses m = Monad m => Map HTTP.Status [(MediaType, Webmachine m ResponseBody)] 130 | 131 | newtype Webmachine m a = 132 | Webmachine { getWebmachine :: (RST RequestReader ResponseState Response m) a } 133 | deriving (Functor, Applicative, Monad, MonadIO, MonadBase b, 134 | MonadReader RequestReader, 135 | MonadState ResponseState) 136 | 137 | instance MonadTrans Webmachine where 138 | lift = Webmachine . RST . helper where 139 | helper m _ s = do 140 | a <- m 141 | return $ (Right a, s) 142 | 143 | newtype StMWebmachine m a = StMWebmachine { 144 | unStMWebmachine :: StM (RST RequestReader ResponseState Response m) a 145 | } 146 | 147 | instance MonadBaseControl b m => MonadBaseControl b (Webmachine m) where 148 | type StM (Webmachine m) a = StMWebmachine m a 149 | liftBaseWith f = Webmachine 150 | $ liftBaseWith 151 | $ \g' -> f 152 | $ \m -> liftM StMWebmachine 153 | $ g' $ getWebmachine m 154 | restoreM = Webmachine . restoreM . unStMWebmachine 155 | 156 | -- Work around old versions of mtl not having a strict modify function 157 | modify'' :: MonadState s m => (s -> s) -> m () 158 | #if MIN_VERSION_mtl(2,2,0) 159 | modify'' = modify' 160 | #else 161 | modify'' f = state (\s -> let s' = f s in s' `seq` ((), s')) 162 | #endif 163 | 164 | -- Functions inside the Webmachine Monad ------------------------------------- 165 | ------------------------------------------------------------------------------ 166 | 167 | -- | Returns the 'Request' that is currently being processed. 168 | request :: Monad m => Webmachine m Request 169 | request = _request . _airshipRequest <$> ask 170 | 171 | -- | Returns the route path that was matched during route evaluation. This is 172 | -- not the path specified in the request, but rather the route in the 173 | -- 'RoutingSpec' that matched the request URL. Variables names are prefixed 174 | -- with @:@, and free ("star") paths are designated with @*@. 175 | routePath :: Monad m => Webmachine m Text 176 | routePath = _routePath . _airshipRequest <$> ask 177 | 178 | -- | Returns the bound routing parameters extracted from the routing system (see "Airship.Route"). 179 | params :: Monad m => Webmachine m (HashMap Text Text) 180 | params = _params <$> get 181 | 182 | dispatchPath :: Monad m => Webmachine m [Text] 183 | dispatchPath = _dispatchPath <$> get 184 | 185 | -- | Returns the time at which this request began processing. 186 | requestTime :: Monad m => Webmachine m UTCTime 187 | requestTime = _now <$> ask 188 | 189 | -- | Returns the current 'ResponseHeaders'. 190 | getResponseHeaders :: Monad m => Webmachine m ResponseHeaders 191 | getResponseHeaders = stateHeaders <$> get 192 | 193 | -- | Returns the current 'ResponseBody'. 194 | getResponseBody :: Monad m => Webmachine m ResponseBody 195 | getResponseBody = stateBody <$> get 196 | 197 | -- | Given a new 'ResponseBody', replaces the stored body with the new one. 198 | putResponseBody :: Monad m => ResponseBody -> Webmachine m () 199 | putResponseBody b = modify'' updateState 200 | where updateState rs = rs {stateBody = b} 201 | 202 | -- | Stores the provided 'ByteString' as the responseBody. This is a shortcut for 203 | -- creating a response body with a 'ResponseBuilder' and a bytestring 'Builder'. 204 | putResponseBS :: Monad m => ByteString -> Webmachine m () 205 | putResponseBS bs = putResponseBody $ ResponseBuilder $ fromByteString bs 206 | 207 | -- | Immediately halts processing with the provided 'Status' code. 208 | -- The contents of the 'Webmachine''s response body will be streamed back to the client. 209 | -- This is a shortcut for constructing a 'Response' with 'getResponseHeaders' and 'getResponseBody' 210 | -- and passing that response to 'finishWith'. 211 | halt :: Monad m => Status -> Webmachine m a 212 | halt status = finishWith =<< Response <$> return status <*> getResponseHeaders <*> getResponseBody 213 | 214 | -- | Immediately halts processing and writes the provided 'Response' back to the client. 215 | finishWith :: Monad m => Response -> Webmachine m a 216 | finishWith = Webmachine . failure 217 | 218 | -- | Adds the provided ByteString to the Airship-Trace header. 219 | addTrace :: Monad m => ByteString -> Webmachine m () 220 | addTrace t = modify'' (\s -> s { decisionTrace = t : decisionTrace s }) 221 | 222 | both :: Either a a -> a 223 | both = either id id 224 | 225 | eitherResponse :: Monad m => RequestReader -> ResponseState -> Webmachine m Response -> m (Response, Trace) 226 | eitherResponse requestReader startingState w = do 227 | (e, trace) <- runWebmachine requestReader startingState w 228 | return (both e, trace) 229 | 230 | -- | Map both the return value and wrapped computation @m@. 231 | mapWebmachine :: ( m1 (Either Response a1, ResponseState) 232 | -> m2 (Either Response a2, ResponseState)) 233 | -> Webmachine m1 a1 -> Webmachine m2 a2 234 | mapWebmachine f = Webmachine . (mapRST f) . getWebmachine 235 | 236 | runWebmachine :: Monad m => RequestReader -> ResponseState -> Webmachine m a -> m (Either Response a, Trace) 237 | runWebmachine requestReader startingState w = do 238 | (e, s) <- runRST (getWebmachine w) requestReader startingState 239 | return (e, reverse $ decisionTrace s) 240 | -------------------------------------------------------------------------------- /airship/test/unit/test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import Airship (requestBody, entireRequestBody, defaultRequest) 5 | import Control.Concurrent (newMVar, modifyMVar) 6 | import Data.ByteString (ByteString) 7 | 8 | import Test.Tasty 9 | import Test.Tasty.HUnit 10 | 11 | main :: IO () 12 | main = defaultMain tests 13 | 14 | tests :: TestTree 15 | tests = testGroup "Tests" [examples] 16 | 17 | examples :: TestTree 18 | examples = testGroup "Examples" [exampleTests] 19 | 20 | exampleTests :: TestTree 21 | exampleTests = testGroup "ExampleTests" 22 | [ bodyTest ] 23 | 24 | bodyChunks :: [ByteString] 25 | bodyChunks = ["one", "two", "three", "four", "five"] 26 | 27 | bodyChunksIO :: IO (IO ByteString) 28 | bodyChunksIO = do 29 | v <- newMVar bodyChunks 30 | return $ modifyMVar v (\l -> return $ case l of { [] -> ([], ""); h : t -> (t, h) }) 31 | 32 | bodyTest :: TestTree 33 | bodyTest = testCase "entireRequestBody returns the body in the correct order" $ do 34 | nextBody <- bodyChunksIO 35 | b <- entireRequestBody defaultRequest { requestBody = nextBody } 36 | b @?= "onetwothreefourfive" 37 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | airship 3 | example 4 | 5 | package airship 6 | ghc-options: -Wall 7 | package example 8 | ghc-options: -Wall 9 | 10 | -------------------------------------------------------------------------------- /doc/authorisation.md: -------------------------------------------------------------------------------- 1 | ## Authorisation 2 | 3 | Authorisation is about whether a request to a resource is allowed. It's closely 4 | connected to authentication, which is concerned with who the request is from. 5 | Airship doesn't directly provide a mechanism for authentication, you are free to 6 | choose how this is done. 7 | 8 | To force authorisation on a resource airship provides an `isAuthorised` 9 | callback. 10 | e.g. 11 | 12 | ``` haskell 13 | 14 | dirigibleResourceV1 :: (Applicative m, MonadIO m) => Resource State m 15 | dirigibleResourceV1 = defaultResource { 16 | allowedMethods = return [ HTTP.methodGet ] 17 | , isAuthorised = checkAuthorisation 18 | } 19 | 20 | checkAuthorisation :: (Applicative m, MonadIO m) => Webmachine s m Bool 21 | checkAuthorisation = do 22 | headers <- lift $ requestHeaders <$> request 23 | let header = lookup hAuthorization headers 24 | return . isJust $ header 25 | 26 | ``` 27 | -------------------------------------------------------------------------------- /doc/versioning-apis.md: -------------------------------------------------------------------------------- 1 | ## Versioning APIs 2 | 3 | Often when building APIs we need a way to version them. Versioning allows 4 | evolving APIs without adding hacks around how to detect which version has been requested. 5 | There are two good approaches available for versioning APIs with Airship (Webmachine). 6 | 7 | ### By URL 8 | Present different urls prefixed by the version of the api 9 | e.g. 10 | ` /v1/dirigible/` and `/v2/dirigible` 11 | 12 | Define the routing urls like so: 13 | 14 | ``` haskell 15 | 16 | routes :: RoutingSpec State IO () 17 | routes = do 18 | "v1" "dirigible" #> dirigibleResourceV1 19 | "v2" "dirigible" #> dirigibleResourceV2 20 | 21 | ``` 22 | 23 | Then define the 2 versions of your resource. Here we handle a json `GET` and 24 | json response. 25 | 26 | ``` haskell 27 | 28 | dirigibleResourceV1 :: (Applicative m, MonadIO m) => Resource State m 29 | dirigibleResourceV1 = defaultResource { 30 | allowedMethods = return [ HTTP.methodGet ] 31 | , knownContentType = contentTypeMatches ["application/json"] 32 | , contentTypesProvided = return [("application/json", handleJsonV1)] 33 | } 34 | 35 | 36 | dirigibleResourceV2 :: (Applicative m, MonadIO m) => Resource State m 37 | dirigibleResourceV2 = defaultResource { 38 | allowedMethods = return [ HTTP.methodGet ] 39 | , knownContentType = contentTypeMatches ["application/json"] 40 | , contentTypesProvided = return [("application/json", handleJsonV2)] 41 | } 42 | 43 | ``` 44 | 45 | You can test this by using curl against the correct url. 46 | ` curl -X GET http://localhost:port/v1/dirigible -H "Content-Type: application/json"` 47 | or 48 | ` curl -X GET http://localhost:port/v2/dirigible -H "Content-Type: application/json"` 49 | 50 | ### By Content-Type 51 | Place the API version into the HTTP Content-Type header. 52 | 53 | ``` haskell 54 | 55 | routes :: RoutingSpec State IO () 56 | routes = do 57 | "dirigible" #> dirigibleResource 58 | ``` 59 | 60 | Then within the resource we handle both versions. 61 | 62 | ``` haskell 63 | 64 | dirigibleResource :: (Applicative m, MonadIO m) => Resource State m 65 | dirigibleResource = defaultResource { 66 | allowedMethods = return [ HTTP.methodGet ] 67 | , knownContentType = contentTypeMatches ["application/json"] 68 | , knownContentTypes = contentTypesProvided ["application/v1+json", "application/v2+json"] 69 | , contentTypesProvided = return [ ("application/v1+json", handleJsonV1) 70 | , ("application/v2+json", handleJsonV2)] 71 | } 72 | 73 | ``` 74 | 75 | Testing this using curl requires setting a custom content type header. 76 | 77 | ` curl -X GET http://localhost:port/dirigible -H "Content-Type: application/v1+json"` 78 | 79 | or 80 | 81 | ` curl -X GET http://localhost:port/dirigible -H "Content-Type: application/v2+json"` 82 | 83 | If you don't supply a `Content-Type` you'll get a 406 Not Acceptable, indicating that no content-type matches. 84 | 85 | Also it's important to note that when testing using `curl` it will by default set an `Accept: */*` indicating that you accept any content-type. This will perform matching on the `contentTypesProvided` list starting at the beginning. So in the example above, V1 appears before V2 which means an `Accept */*` will match V1 first and never get to V2. 86 | -------------------------------------------------------------------------------- /example/Basic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | module Basic where 7 | 8 | import Airship 9 | import Airship.Resource.Static (StaticOptions (..), 10 | staticResource) 11 | 12 | import Blaze.ByteString.Builder.Html.Utf8 (fromHtmlEscapedText) 13 | 14 | #if __GLASGOW_HASKELL__ < 710 15 | import Control.Applicative ((<$>)) 16 | #endif 17 | import Control.Concurrent.MVar 18 | import Control.Monad.State hiding (State) 19 | 20 | import qualified Data.ByteString.Lazy as LB 21 | import Data.ByteString.Lazy.Char8 (unpack) 22 | import Data.HashMap.Strict (HashMap) 23 | import qualified Data.HashMap.Strict as HM 24 | import qualified Data.Map.Strict as M 25 | import Data.Maybe (fromMaybe) 26 | import Data.Monoid ((<>)) 27 | import Data.Text (Text, pack) 28 | import Data.Time.Clock 29 | 30 | import qualified Network.HTTP.Types as HTTP 31 | import Network.Wai.Handler.Warp (defaultSettings, 32 | runSettings, setHost, 33 | setPort) 34 | 35 | -- *************************************************************************** 36 | -- Helpers 37 | -- *************************************************************************** 38 | 39 | getBody :: MonadIO m => Webmachine m LB.ByteString 40 | getBody = do 41 | req <- request 42 | liftIO (entireRequestBody req) 43 | 44 | readBody :: MonadIO m => Webmachine m Integer 45 | readBody = read . unpack <$> getBody 46 | 47 | routingParam :: Monad m => Text -> Webmachine m Text 48 | routingParam t = do 49 | p <- params 50 | return (p HM.! t) 51 | 52 | newtype State = State { _getState :: MVar (HashMap Text Integer) } 53 | 54 | resourceWithBody :: (MonadIO m, MonadState State m) => Text -> Resource m 55 | resourceWithBody t = defaultResource { contentTypesProvided = return [("text/plain", return (escapedResponse t))] 56 | , lastModified = Just <$> liftIO getCurrentTime 57 | , generateETag = return $ Just $ Strong "abc123" 58 | } 59 | 60 | accountResource :: (MonadIO m, MonadState State m) => Resource m 61 | accountResource = defaultResource 62 | { allowedMethods = return [ HTTP.methodGet 63 | , HTTP.methodHead 64 | , HTTP.methodPost 65 | , HTTP.methodPut 66 | ] 67 | , knownContentType = contentTypeMatches ["text/plain"] 68 | 69 | , contentTypesProvided = do 70 | let textAction = do 71 | s <- lift get 72 | m <- liftIO (readMVar (_getState s)) 73 | accountNameM <- HM.lookup "name" <$> params 74 | let val = fromMaybe 0 (accountNameM >>= flip HM.lookup m) 75 | return $ ResponseBuilder (fromHtmlEscapedText 76 | (pack (show val) <> "\n")) 77 | return [("text/plain", textAction)] 78 | 79 | , allowMissingPost = return False 80 | 81 | , lastModified = Just <$> liftIO getCurrentTime 82 | 83 | , resourceExists = do 84 | accountName <- routingParam "name" 85 | s <- lift get 86 | m <- liftIO (readMVar (_getState s)) 87 | return $ HM.member accountName m 88 | 89 | -- POST'ing to this resource adds the integer to the current value 90 | , processPost = return (PostProcess [("text/plain", do 91 | (val, accountName, s) <- postPutStates 92 | liftIO (modifyMVar_ (_getState s) (return . HM.insertWith (+) accountName val)) 93 | return () 94 | )]) 95 | 96 | , contentTypesAccepted = return [("text/plain", do 97 | (val, accountName, s) <- postPutStates 98 | liftIO (modifyMVar_ (_getState s) (return . HM.insert accountName val)) 99 | return () 100 | )] 101 | } 102 | 103 | postPutStates :: (MonadIO m, MonadState State m) => Webmachine m (Integer, Text, State) 104 | postPutStates = do 105 | val <- readBody 106 | accountName <- routingParam "name" 107 | s <- lift get 108 | return (val, accountName, s) 109 | 110 | myRoutes :: Resource (StateT State IO) -> RoutingSpec (StateT State IO) () 111 | myRoutes static = do 112 | root #> resourceWithBody "Just the root resource" 113 | "account" var "name" #> accountResource 114 | "static" star #> static 115 | 116 | main :: IO () 117 | main = do 118 | static <- staticResource Cache "assets" 119 | let port = 3000 120 | host = "127.0.0.1" 121 | settings = setPort port (setHost host defaultSettings) 122 | routes = myRoutes static 123 | mvar <- newMVar HM.empty 124 | let s = State mvar 125 | putStrLn "Listening on port 3000" 126 | runSettings settings (resourceToWaiT defaultAirshipConfig (const $ flip evalStateT s) routes errors) 127 | where 128 | errors = let response404 = escapedResponse "

404 Not Found

" 129 | in M.singleton HTTP.status404 [("text/html", return response404)] 130 | -------------------------------------------------------------------------------- /example/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Helium Systems, Inc. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /example/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/Versions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | module Versions where 7 | 8 | import Airship 9 | import Blaze.ByteString.Builder.ByteString (fromByteString) 10 | #if __GLASGOW_HASKELL__ < 710 11 | import Control.Applicative ((<$>)) 12 | #endif 13 | import Control.Concurrent.MVar 14 | import Control.Monad.State hiding (State) 15 | 16 | import qualified Data.ByteString.Lazy as BSL 17 | import qualified Data.Text as T 18 | 19 | import Data.Aeson 20 | import qualified Data.Map as M 21 | import qualified Data.UUID as U 22 | import qualified Data.UUID.V4 as U 23 | import qualified Network.HTTP.Types as HTTP 24 | import Network.Wai.Handler.Warp (defaultSettings, 25 | runSettings, setHost, 26 | setPort) 27 | import qualified System.IO as IO 28 | 29 | -- *************************************************************************** 30 | -- Basic Data Store 31 | -- *************************************************************************** 32 | type Db = MVar (M.Map DirigibleId Dirigible) 33 | 34 | createDb :: IO Db 35 | createDb = do 36 | s <- newMVar M.empty 37 | return s 38 | 39 | insert :: Db -> Dirigible -> IO DirigibleId 40 | insert db t = do 41 | uuid <- liftIO U.nextRandom >>= return . DirigibleId . T.pack . U.toString 42 | modifyMVar_ db $ \m -> 43 | return $ M.insert uuid t m 44 | return uuid 45 | 46 | list :: Db -> IO [(DirigibleId, Dirigible)] 47 | list t = modifyMVar t $ \m -> 48 | return (m, M.assocs m) 49 | 50 | -- *************************************************************************** 51 | -- Data Types 52 | -- *************************************************************************** 53 | newtype DirigibleId = DirigibleId { unDirigibleId :: T.Text } deriving (Eq, Show, Ord) 54 | 55 | data Dirigible = Dirigible { 56 | dName :: T.Text 57 | , dEngines :: Int 58 | , dCaptain :: Maybe T.Text 59 | , dLiftCapacity :: Integer 60 | } deriving (Eq, Show, Ord) 61 | 62 | newtype DirigibleV1 = DirigibleV1 Dirigible 63 | newtype DirigibleV2 = DirigibleV2 Dirigible 64 | 65 | instance ToJSON DirigibleV1 where 66 | toJSON (DirigibleV1 (Dirigible n e c l)) = 67 | object [ "name" .= n 68 | , "engines" .= e 69 | , "captain" .= c 70 | , "lift_capacity" .= l] 71 | 72 | instance ToJSON DirigibleV2 where 73 | toJSON (DirigibleV2 (Dirigible n e _c l)) = 74 | object [ "name" .= n 75 | , "engines" .= e 76 | , "lift_capacity" .= l] 77 | 78 | instance ToJSON DirigibleId where 79 | toJSON (DirigibleId i) = 80 | object [ "id" .= i ] 81 | 82 | jsonResponseV1 :: Db -> Webmachine IO ResponseBody 83 | jsonResponseV1 db = do 84 | t <- lift $ list db 85 | return $ encodeResponse ((\(x,y) -> (x, DirigibleV1 y)) <$> t) 86 | 87 | jsonResponseV2 :: Db -> Webmachine IO ResponseBody 88 | jsonResponseV2 db = do 89 | t <- lift $ list db 90 | return $ encodeResponse ((\(x,y) -> (x, DirigibleV2 y)) <$> t) 91 | 92 | dirigibleResource :: Db -> Resource IO 93 | dirigibleResource db = defaultResource { 94 | allowedMethods = return [ HTTP.methodGet ] 95 | , contentTypesProvided = return [ ("application/v1+json", jsonResponseV1 db) 96 | , ("application/v2+json", jsonResponseV2 db)] 97 | } 98 | 99 | encodeResponse :: ToJSON a => a -> ResponseBody 100 | encodeResponse = ResponseBuilder . fromByteString . BSL.toStrict . encode 101 | 102 | routes :: Db -> RoutingSpec IO () 103 | routes db = do 104 | "dirigible" #> dirigibleResource db 105 | 106 | main :: IO () 107 | main = do 108 | let port = 3000 109 | host = "127.0.0.1" 110 | settings = setPort port (setHost host defaultSettings) 111 | db <- createDb 112 | insertDirigibles db 113 | IO.putStrLn "Listening on port 3000" 114 | runSettings settings (resourceToWai defaultAirshipConfig (routes db) errors) 115 | where 116 | errors = let response404 = escapedResponse "

404 Not Found

" 117 | in M.singleton HTTP.status404 [("text/html", return response404)] 118 | 119 | insertDirigibles :: Db -> IO () 120 | insertDirigibles db = do 121 | let a = [ Dirigible "La France" 1 (Just "Charles Renard") 100 122 | , Dirigible "Luftschiff Zeppelin LZ1" 2 (Just "Count von Zeppelin") 12428 ] 123 | forM_ a $ insert db 124 | 125 | 126 | -- curl -X GET http://localhost:3000/dirigible -v -H "Accept: application/v1+json" 127 | -- gives V1 of the api 128 | -- 129 | -- curl -X GET http://localhost:3000/dirigible -v -H "Accept: application/v2+json" 130 | -- gives V2 of the api 131 | -- 132 | -- curl -X GET http://localhost:3000/dirigible -v 133 | -- gives Accept: * / * so it matches V1 134 | -------------------------------------------------------------------------------- /example/airship-example.cabal: -------------------------------------------------------------------------------- 1 | name: airship-example 2 | synopsis: A Webmachine-inspired HTTP library 3 | description: Examples for Airship: A Webmachine-inspired HTTP library 4 | version: 0.6.0.0 5 | license: MIT 6 | license-file: LICENSE 7 | author: Reid Draper and Patrick Thomson 8 | maintainer: Tim McGilchrist 9 | category: Web 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | tested-with: GHC == 7.10.3, 13 | GHC == 8.0.2, 14 | GHC == 8.2.2, 15 | GHC == 8.4.3, 16 | GHC == 8.6.3, 17 | GHC == 8.8.2 18 | 19 | executable basic 20 | main-is: Basic.hs 21 | ghc-options: -threaded -main-is Basic 22 | default-language: Haskell2010 23 | hs-source-dirs: . 24 | build-depends: base >=4.7 && < 5 25 | , airship 26 | , blaze-builder >=0.3 && < 0.5 27 | , bytestring 28 | , containers 29 | , http-media 30 | , http-types >= 0.7 31 | , mtl 32 | , text 33 | , time 34 | , unordered-containers 35 | , wai 36 | , warp 37 | 38 | executable versions 39 | main-is: Versions.hs 40 | ghc-options: -threaded -main-is Versions 41 | default-language: Haskell2010 42 | hs-source-dirs: . 43 | build-depends: base >=4.7 && < 5 44 | , airship 45 | , blaze-builder >=0.3 && < 0.5 46 | , bytestring 47 | , containers 48 | , http-media 49 | , http-types >= 0.7 50 | , mtl 51 | , text 52 | , time 53 | , unordered-containers 54 | , transformers 55 | , containers 56 | , uuid 57 | , aeson 58 | , wai 59 | , warp 60 | --------------------------------------------------------------------------------