├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── CHANGELOG.md ├── COPYING ├── README.md ├── Setup.hs ├── attic ├── Examples │ ├── AllIn.hs │ ├── Cookies.hs │ ├── DistributedChat │ │ ├── ChatLogin.html │ │ ├── ChatRun.html │ │ ├── DistributedChat.hs │ │ └── readme.txt │ ├── MultimasterTest1.hs │ ├── MultimasterTest2.hs │ ├── Timer.hs │ ├── Validation.lhs │ ├── dist-newstyle │ │ └── cache │ │ │ └── config │ └── set │ │ ├── FromData │ │ ├── Basics.hs │ │ ├── Cookies.hs │ │ ├── Inline.hs │ │ └── Optional.hs │ │ ├── ServerPart │ │ ├── HelloWorld.hs │ │ ├── PathSegments.hs │ │ └── SideEffects.hs │ │ └── Web │ │ ├── ControlFlow.hs │ │ ├── ErrorCodes.hs │ │ ├── FileServe.hs │ │ ├── IO.hs │ │ └── Trace.hs └── xslt │ ├── defaultStyle.xsl │ ├── defaultXML.xsl │ ├── forms.xsl │ ├── forms2.xsl │ ├── forms3.xsl │ ├── script.js │ ├── style.css │ └── xslt2.dtd ├── cabal.haskell-ci ├── default.nix ├── happstack-server.cabal ├── original-context.txt ├── src └── Happstack │ ├── Server.hs │ └── Server │ ├── Auth.hs │ ├── Compression.hs │ ├── Cookie.hs │ ├── Error.hs │ ├── FileServe.hs │ ├── FileServe │ ├── BuildingBlocks.hs │ └── GenMimeTypes.hs │ ├── I18N.hs │ ├── Internal │ ├── Clock.hs │ ├── Compression.hs │ ├── Cookie.hs │ ├── Handler.hs │ ├── LazyLiner.hs │ ├── Listen.hs │ ├── LogFormat.hs │ ├── LowLevel.hs │ ├── MessageWrap.hs │ ├── Monads.hs │ ├── Multipart.hs │ ├── NoPush.hsc │ ├── RFC822Headers.hs │ ├── Socket.hs │ ├── Timeout.hs │ ├── TimeoutIO.hs │ ├── TimeoutManager.hs │ ├── TimeoutSocket.hs │ └── Types.hs │ ├── Monads.hs │ ├── Response.hs │ ├── Routing.hs │ ├── RqData.hs │ ├── SURI.hs │ ├── SURI │ └── ParseURI.hs │ ├── SimpleHTTP.hs │ ├── StdConfig.hs │ ├── Types.hs │ ├── UDP.hs │ └── Validation.hs └── tests ├── Happstack └── Server │ └── Tests.hs ├── Makefile └── Test.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'happstack-server.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/andreasabel/haskell-ci 10 | # 11 | # version: 0.17.20231012 12 | # 13 | # REGENDATA ("0.17.20231012",["github","happstack-server.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | push: 18 | branches: 19 | - master 20 | pull_request: 21 | branches: 22 | - master 23 | jobs: 24 | linux: 25 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 26 | runs-on: ubuntu-20.04 27 | timeout-minutes: 28 | 60 29 | container: 30 | image: buildpack-deps:focal 31 | continue-on-error: ${{ matrix.allow-failure }} 32 | strategy: 33 | matrix: 34 | include: 35 | - compiler: ghc-9.10.1 36 | compilerKind: ghc 37 | compilerVersion: 9.10.1 38 | setup-method: ghcup 39 | allow-failure: false 40 | - compiler: ghc-9.8.2 41 | compilerKind: ghc 42 | compilerVersion: 9.8.2 43 | setup-method: ghcup 44 | allow-failure: false 45 | - compiler: ghc-9.6.3 46 | compilerKind: ghc 47 | compilerVersion: 9.6.3 48 | setup-method: ghcup 49 | allow-failure: false 50 | - compiler: ghc-9.4.7 51 | compilerKind: ghc 52 | compilerVersion: 9.4.7 53 | setup-method: ghcup 54 | allow-failure: false 55 | - compiler: ghc-9.2.8 56 | compilerKind: ghc 57 | compilerVersion: 9.2.8 58 | setup-method: ghcup 59 | allow-failure: false 60 | - compiler: ghc-9.0.2 61 | compilerKind: ghc 62 | compilerVersion: 9.0.2 63 | setup-method: ghcup 64 | allow-failure: false 65 | - compiler: ghc-8.10.7 66 | compilerKind: ghc 67 | compilerVersion: 8.10.7 68 | setup-method: ghcup 69 | allow-failure: false 70 | - compiler: ghc-8.8.4 71 | compilerKind: ghc 72 | compilerVersion: 8.8.4 73 | setup-method: ghcup 74 | allow-failure: false 75 | - compiler: ghc-8.6.5 76 | compilerKind: ghc 77 | compilerVersion: 8.6.5 78 | setup-method: ghcup 79 | allow-failure: false 80 | - compiler: ghc-8.4.4 81 | compilerKind: ghc 82 | compilerVersion: 8.4.4 83 | setup-method: ghcup 84 | allow-failure: false 85 | - compiler: ghc-8.2.2 86 | compilerKind: ghc 87 | compilerVersion: 8.2.2 88 | setup-method: ghcup 89 | allow-failure: false 90 | - compiler: ghc-8.0.2 91 | compilerKind: ghc 92 | compilerVersion: 8.0.2 93 | setup-method: ghcup 94 | allow-failure: false 95 | fail-fast: false 96 | steps: 97 | - name: apt 98 | run: | 99 | apt-get update 100 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 101 | mkdir -p "$HOME/.ghcup/bin" 102 | curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$HOME/.ghcup/bin/ghcup" 103 | chmod a+x "$HOME/.ghcup/bin/ghcup" 104 | "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml; 105 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 106 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 107 | env: 108 | HCKIND: ${{ matrix.compilerKind }} 109 | HCNAME: ${{ matrix.compiler }} 110 | HCVER: ${{ matrix.compilerVersion }} 111 | - name: Set PATH and environment variables 112 | run: | 113 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 114 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 115 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 116 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 117 | HCDIR=/opt/$HCKIND/$HCVER 118 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 119 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 120 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 121 | echo "HC=$HC" >> "$GITHUB_ENV" 122 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 123 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 124 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 125 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 126 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 127 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 128 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 129 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 130 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 131 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 132 | env: 133 | HCKIND: ${{ matrix.compilerKind }} 134 | HCNAME: ${{ matrix.compiler }} 135 | HCVER: ${{ matrix.compilerVersion }} 136 | - name: env 137 | run: | 138 | env 139 | - name: write cabal config 140 | run: | 141 | mkdir -p $CABAL_DIR 142 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 175 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 176 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 177 | rm -f cabal-plan.xz 178 | chmod a+x $HOME/.cabal/bin/cabal-plan 179 | cabal-plan --version 180 | - name: checkout 181 | uses: actions/checkout@v4 182 | with: 183 | path: source 184 | env: 185 | ACTIONS_ALLOW_USE_UNSECURE_NODE_VERSION: true 186 | - name: initial cabal.project for sdist 187 | run: | 188 | touch cabal.project 189 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 190 | cat cabal.project 191 | - name: sdist 192 | run: | 193 | mkdir -p sdist 194 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 195 | - name: unpack 196 | run: | 197 | mkdir -p unpacked 198 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 199 | - name: generate cabal.project 200 | run: | 201 | PKGDIR_happstack_server="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/happstack-server-[0-9.]*')" 202 | echo "PKGDIR_happstack_server=${PKGDIR_happstack_server}" >> "$GITHUB_ENV" 203 | rm -f cabal.project cabal.project.local 204 | touch cabal.project 205 | touch cabal.project.local 206 | echo "packages: ${PKGDIR_happstack_server}" >> cabal.project 207 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package happstack-server" >> cabal.project ; fi 208 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi 209 | cat >> cabal.project <> cabal.project.local 212 | cat cabal.project 213 | cat cabal.project.local 214 | - name: dump install plan 215 | run: | 216 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 217 | cabal-plan 218 | - name: restore cache 219 | uses: actions/cache/restore@v3 220 | with: 221 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 222 | path: ~/.cabal/store 223 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 224 | - name: install dependencies 225 | run: | 226 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 227 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 228 | - name: build w/o tests 229 | run: | 230 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 231 | - name: build 232 | run: | 233 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 234 | - name: tests 235 | run: | 236 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 237 | - name: cabal check 238 | run: | 239 | cd ${PKGDIR_happstack_server} || false 240 | ${CABAL} -vnormal check 241 | - name: haddock 242 | run: | 243 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 244 | - name: unconstrained build 245 | run: | 246 | rm -f cabal.project.local 247 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 248 | - name: save cache 249 | uses: actions/cache/save@v3 250 | if: always() 251 | with: 252 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 253 | path: ~/.cabal/store 254 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist-newstyle 2 | .cabal-sandbox 3 | cabal.sandbox.config 4 | dist 5 | .env 6 | .anvil 7 | .ghc.environment.* 8 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 7.7.1 2 | ===== 3 | 4 | - fix listenOnIPv4 / inet_addr 5 | 6 | 7.7.0 7 | ===== 8 | 9 | - added support for specifying SameSite attribute 10 | 11 | 7.6.0 12 | ===== 13 | 14 | - updated to support network 3.* and GHC 8.8.1 15 | 16 | - removed Happstack.Server.Client and Happstack.Server.Proxy under the 17 | belief that no one uses them. This makes the upgrade to network 3 18 | easier. If you used these, let us know. 19 | 20 | 7.5.1 21 | ===== 22 | 23 | - anyone using base < 4.10 should upgrade to 7.5.1 or higher 24 | - disallow path separator in filename for POST data (reported by Hamid Ebadi) 25 | 26 | 7.4.6 27 | ===== 28 | 29 | - Allow transformers 0.5.* and transformers-compat 0.5.* 30 | 31 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Copyright (c) 2006, HAppS.org 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 15 | Neither the name of the HAppS.org; nor the names of its contributors 16 | may be used to endorse or promote products derived from this software 17 | without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 23 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 24 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 25 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 26 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 27 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 28 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 29 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # happstack-server [![Hackage Status](https://img.shields.io/hackage/v/happstack-server.svg)][hackage] 2 | 3 | [hackage]: https://hackage.haskell.org/package/happstack-server 4 | 5 | Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course http://happstack.com/docs/crashcourse/index.html. 6 | 7 | ## Install 8 | 9 | There are packages available on [hackage][] and [stack](https://www.stackage.org/lts-3.12/package/happstack-server-7.4.5). 10 | 11 | ## Documentation 12 | 13 | Please refer to the [Documentation on Hackage][hackage]. 14 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | import Distribution.Simple 3 | main = defaultMainWithHooks simpleUserHooks 4 | -------------------------------------------------------------------------------- /attic/Examples/AllIn.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fglasgow-exts #-} 2 | {-# LANGUAGE TemplateHaskell , FlexibleInstances, UndecidableInstances, OverlappingInstances, 3 | MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} 4 | 5 | import Happstack.Server 6 | 7 | import Happstack.State 8 | import Control.Concurrent 9 | import Control.Monad 10 | import Control.Monad.Reader 11 | import Control.Monad.State (modify,put,get,gets) 12 | import Data.Generics hiding ((:+:)) 13 | import Happstack.Data 14 | import Happstack.Data.IxSet 15 | 16 | import qualified Data.Map as M 17 | 18 | ------------------------------------------------ 19 | -- Define a component of state 20 | -- 21 | -- Real examples are HelpReqs, FlashMsgs, and sessions 22 | -- really you should put components in their own modules. 23 | ---------------------------------------------- 24 | 25 | -- State is global and composed of components that have component 26 | -- specific methods. The system generates special instance 27 | -- declarations to access the component inside the global state. 28 | 29 | -- Lets start with defining a simple state component: Session 30 | type SesKey = Integer 31 | type ETime = Integer 32 | newtype OldSession val = OldSession {old_unsession::[(SesKey,(ETime,val))]} 33 | deriving (Typeable) 34 | 35 | instance Version (OldSession val) 36 | $(deriveSerialize ''OldSession) 37 | 38 | 39 | newtype Session val = Session { unsession :: M.Map SesKey (ETime,val) } 40 | deriving (Typeable) 41 | 42 | instance Migrate (OldSession val) (Session val) where 43 | migrate (OldSession sess) = Session (M.fromList sess) 44 | 45 | instance Serialize val => Version (Session val) where 46 | mode = extension 1 (Proxy :: Proxy (OldSession val)) 47 | $(deriveSerialize ''Session) 48 | 49 | 50 | 51 | -- Note that we don't use the list directly because we may want this 52 | -- list type for other purposes so we make it a newtype. Now since 53 | -- all methods are going to be inside our Update (aka State) or Query 54 | -- (aka Reader) monads, it is useful to define some accessors. the 55 | -- typesig is necessary for askSession because we don't know the type 56 | -- until the end. 57 | askSession::MonadReader (Session val) m => m (M.Map SesKey (ETime,val)) 58 | askSession = return . unsession =<< ask 59 | modSession f = modify (Session . f . unsession) 60 | 61 | 62 | 63 | -- Now define some methods that will operate on Session state. 64 | newSession val = do 65 | key <- getRandom 66 | t <- getTime 67 | modSession $ M.insert key (t,val) 68 | return key 69 | 70 | getSession :: SesKey -> Query (Session val) (Maybe val) 71 | getSession key = do val <- liftM (M.lookup key) askSession 72 | return (liftM snd val) 73 | 74 | setSession key val = do 75 | t <- getTime 76 | modSession $ M.insert key (t,val) 77 | return () 78 | 79 | 80 | 81 | -- Numsessions and cleansessions take a proxy type as an argument so 82 | -- we know which session you want. You may have sessions on more than 83 | -- one type in state operating or sessions may be nested elsewhere. 84 | -- You can only have one of each type in all of state. 85 | 86 | --cleanSessions :: Proxy (Session key) -> ETime -> Update (Session key) () 87 | cleanSessions age = proxyUpdate $ do 88 | t <- getTime 89 | let minTime = t-age 90 | modSession $ M.filterWithKey (\k _ -> k>t) 91 | return () 92 | 93 | 94 | -- The type sig is required for reasons I don't understand 95 | numSessions:: Proxy (Session val) -> Query (Session val) Int 96 | numSessions = proxyQuery $ liftM M.size askSession 97 | 98 | -- Declare these as methods. So you can access them from any IO via (query $ 99 | -- GetSession key) or (update $ setSession key val). When we can have 100 | -- Data for phantom types in 6.8.2 this will look nicer 101 | 102 | $(mkMethods ''Session 103 | ['newSession,'setSession, 'cleanSessions,'numSessions ,'getSession]) 104 | 105 | -- Sometimes you want maintenance on your component that the user 106 | -- doesn't want to worry about. 107 | 108 | maintainSessions v = do update $ CleanSessions 3600000 v 109 | threadDelay (10^6 * 10) -- Once every 10 seconds 110 | maintainSessions v 111 | 112 | instance (Serialize a) => Component (Session a) where 113 | type Dependencies (Session a) = End 114 | initialValue = Session M.empty 115 | 116 | -- All components need an atStart declaration though the list can be empty 117 | 118 | -- Now we repeat the above for a more trivial example so we have 119 | -- multiple components in state. But we'll use the more concise deriveAll syntax 120 | -- so you don't deal with the boilerplate of a zillion deriving declarations on each type. 121 | 122 | data UserComponent key = UserComponent {unUserComponent :: key} deriving (Typeable) 123 | data SingletonComponent = SingletonComponent {unSingleton :: String} deriving (Typeable) 124 | 125 | instance Version (UserComponent key) 126 | $(deriveSerialize ''UserComponent) 127 | instance Version SingletonComponent 128 | $(deriveSerialize ''SingletonComponent) 129 | 130 | 131 | -- methods definition for these two components 132 | setSingleton str = put (SingletonComponent str) 133 | -- need an argument or to disable the monomorphism restriction or a type-sig 134 | getSingleton () = liftM unSingleton ask 135 | setComponent c = put (UserComponent c) 136 | getComponent () = liftM unUserComponent ask 137 | 138 | -- method declarations 139 | $(mkMethods ''UserComponent ['getComponent,'setComponent]) 140 | $(mkMethods ''SingletonComponent ['setSingleton,'getSingleton]) 141 | 142 | -- now you can use (query GetComponent) and (update $ SetComponent c) 143 | -- with any state that has one field of type Component 144 | 145 | singletonIO Proxy 146 | = do putStrLn "Initializing singleton component" 147 | update $ SetSingleton "init" 148 | 149 | -- this is complex because we want this to work even though the methods don't need proxies 150 | -- we need userComponent to initialize against each different type inside state. 151 | userComponentIO :: forall key. Serialize key => Proxy (UserComponent key) -> IO () 152 | userComponentIO proxy 153 | = do putStrLn $ "Initializing component of type: " ++ show (typeOf (unProxy proxy)) 154 | query (GetComponent ()) :: IO key 155 | return () 156 | 157 | instance (Default key, Serialize key) => Component (UserComponent key) where 158 | type Dependencies (UserComponent key) = End 159 | onLoad = userComponentIO 160 | initialValue = UserComponent defaultValue 161 | 162 | instance Component SingletonComponent where 163 | type Dependencies SingletonComponent = End 164 | onLoad = singletonIO 165 | initialValue = SingletonComponent "" 166 | 167 | --------------------------------------------------------------------- 168 | -- Now lets define a state that has its own methods and uses some components. 169 | ------------------------------------------------------------------------ 170 | {-- This also works 171 | $(deriveAll [''Show,''Default, ''Read] 172 | [d| 173 | data State = State { privateInt :: Int 174 | , privateString :: String 175 | , someComponent1 :: Component (UserComponent Int) 176 | , someComponent2 :: Component (UserComponent String) 177 | , singleton :: Component SingletonComponent 178 | , sessions :: Component (Session String) 179 | } 180 | |] 181 | ) 182 | --} 183 | 184 | data State = State { privateInt :: Int 185 | , privateString :: String 186 | } deriving (Typeable) 187 | 188 | instance Version State 189 | $(deriveSerialize ''State) 190 | 191 | -- Bind privateInt and privateString in a tuple. 192 | getPrivateData () = liftM2 (,) (asks privateInt) (asks privateString) 193 | 194 | setPrivateData int string = modify $ \s -> s{privateInt = int 195 | ,privateString = string} 196 | 197 | -- notice that state is also a component with methods 198 | 199 | $(mkMethods ''State ['getPrivateData, 'setPrivateData]) 200 | 201 | instance Component State where 202 | type Dependencies State = UserComponent Int :+: 203 | UserComponent String :+: 204 | SingletonComponent :+: 205 | Session String :+: 206 | End 207 | initialValue = State 0 "" 208 | 209 | 210 | ---------------------------------------------------- 211 | -- Now we define the HTTP interface to test stuff 212 | ---------------------------------------- 213 | impl = dir "setGet" $ msum 214 | [--return text/plain of the string inside component 215 | --you can return a type and have it convert automatically to XML (see below) 216 | --you can return Text.HTML and Text.XHTML and they will be handled properly too 217 | do 218 | methodM GET 219 | ok () 220 | liftIO $ query $ GetComponent () 221 | --method GET $ ok =<< (webQuery (GetComponent ()) :: Web Int) 222 | 223 | -- receive urlencoded or mimemultipart of ?component=blah 224 | -- handle other encodings by defining your own FromData 225 | , do 226 | methodM POST 227 | mbComp <- getData 228 | comp <- maybe mzero return mbComp 229 | liftIO $ update $ SetComponent (comp :: Int) 230 | ok comp -- returned as blah. 231 | -- add the xslt wrapper to style the xml 232 | -- or write your own ToMessage instance for your return types 233 | ] 234 | 235 | -- and a test we can run from anywhere 236 | ioTest = do print =<< query (GetPrivateData ()) 237 | update $ SetPrivateData 10 "Hello world" 238 | print =<< query (GetPrivateData ()) 239 | update $ SetComponent (10::Int) 240 | print =<< (query (GetComponent ()) :: IO Int) 241 | update $ SetSingleton "Hello HAppS from Haskell" 242 | putStrLn =<< query (GetSingleton ()) 243 | 244 | entryPoint :: Proxy State 245 | entryPoint = Proxy 246 | 247 | main = do control <- startSystemState entryPoint 248 | tid <- forkIO $ simpleHTTP nullConf impl 249 | {- 250 | readEvent <- getEventStream 251 | forkIO $ forever $ do event <- readEvent 252 | putStrLn $ "New event: " ++ show event 253 | -} 254 | ioTest 255 | waitForTermination 256 | killThread tid 257 | shutdownSystem control 258 | -------------------------------------------------------------------------------- /attic/Examples/Cookies.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | 4 | module Main where 5 | 6 | import Control.Applicative (optional) 7 | import Control.Monad (msum) 8 | import Data.Maybe (fromMaybe) 9 | import Data.Text.Lazy (unpack) 10 | import Happstack.Server 11 | import Text.Blaze.Html5 (Html, (!)) 12 | import qualified Text.Blaze.Html5 as H 13 | import qualified Text.Blaze.Html5.Attributes as A 14 | 15 | -------------------------------------------------------------------------------- 16 | 17 | 18 | serve :: ServerPart Response -> IO () 19 | serve part = 20 | let 21 | ramQuota = 1 * 10^6 22 | diskQuota = 20 * 10^6 23 | tmpDir = "/tmp/" 24 | policy = defaultBodyPolicy tmpDir diskQuota ramQuota (ramQuota `div` 10) 25 | in 26 | simpleHTTP (nullConf { port = 8000}) $ do 27 | decodeBody policy 28 | part 29 | 30 | 31 | 32 | main :: IO () 33 | main = serve $ msum [setCookie, getCookie] 34 | 35 | 36 | setCookie :: ServerPart Response 37 | setCookie = do 38 | method POST 39 | newCk <- lookText "new-msg" 40 | addCookies 41 | [(,) Session (mkCookie "theCookie" $ unpack newCk) 42 | ] 43 | seeOther ("/" :: String) $ toResponse () 44 | 45 | 46 | getCookie :: ServerPart Response 47 | getCookie = do 48 | method GET 49 | mMemory <- optional $ lookCookieValue "theCookie" 50 | let memory = fromMaybe "No saved message." mMemory 51 | ok $ toResponse $ viewCookie memory 52 | 53 | 54 | -------------------------------------------------------------------------------- 55 | 56 | 57 | viewCookie :: String -> Html 58 | viewCookie msg = 59 | H.html $ do 60 | H.head $ do 61 | H.title "Happstack cookies example" 62 | H.style (H.toHtml viewCookieCss) 63 | H.body $ 64 | H.form 65 | ! A.method "post" 66 | ! A.action "/" 67 | $ do 68 | H.h3 "Happstack cookies example" 69 | H.p "The message in your cookie says:" 70 | H.h5 (H.toHtml msg) 71 | H.p "Enter new message:" 72 | H.div 73 | ! A.style "display:flex; align-items: center;" 74 | $ do 75 | H.input 76 | ! A.type_ "text" 77 | ! A.name "new-msg" 78 | H.button "☛" 79 | ! A.type_ "submit" 80 | 81 | 82 | 83 | viewCookieCss :: String 84 | viewCookieCss = concat 85 | [ "* {box-sizing:border-box; margin:0; padding:0; }" 86 | , "body {" 87 | , " display:flex; justify-content:center; align-items:center; " 88 | , " min-height:100vh; " 89 | , " font-family: Arial, Helvetica, sans-serif; color: navy;" 90 | , " background-image: " 91 | , " radial-gradient(circle farthest-corner at 5% 50%, gold, transparent)," 92 | , " radial-gradient(circle farthest-corner at 95% 50%, #f06, transparent);" 93 | , "} " 94 | , "form { " 95 | , " padding: 40px 60px;" 96 | , " border: 1px solid silver; border-radius: 15px;" 97 | , " background-color: rgb(235,235,255);" 98 | , " box-shadow: 1px 1px 5px 3px rgba(0,0,0,0.2);" 99 | , " }" 100 | , "h3 {" 101 | , " margin-bottom:30px; padding-bottom:8px; border-bottom:1px solid silver;" 102 | , " font-variant: small-caps; color: navy;" 103 | , " text-transform: capitalize;" 104 | , "}" 105 | , "p {" 106 | , " font-size: 12px; margin-bottom: 12px;" 107 | , "}" 108 | , "h5 {" 109 | , " margin-bottom: 20px; text-align: center; color: teal;" 110 | , "}" 111 | , "input {" 112 | , " height: 45px; width: 350px; margin-right: 15px; padding: 10px;" 113 | , " border: 1px solid navy; border-radius: 2px; " 114 | , "}" 115 | , "button {" 116 | , " height: 45px; width: 45px; margin-left: 0px;" 117 | , " display: flex; justify-content: center; align-items: center;" 118 | , " border: 1px solid navy; border-radius: 100px;" 119 | , " background: white;" 120 | , " font-size: 25px;" 121 | , " transition: all 2s; cursor: pointer;" 122 | , "}" 123 | , "input:focus {border-color: blue;}" 124 | , "button:hover {" 125 | , " background-color: rgb(80,255,100); " 126 | , " transform: rotate(1440deg); height: 60px; width: 60px;" 127 | , " margin-left: 15px;" 128 | , "}" 129 | ] 130 | 131 | 132 | -------------------------------------------------------------------------------- 133 | -------------------------------------------------------------------------------- /attic/Examples/DistributedChat/ChatLogin.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Login 5 | 6 | 7 |
8 | Enter nick: 9 |
10 | 11 | -------------------------------------------------------------------------------- /attic/Examples/DistributedChat/ChatRun.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Chat 5 | 92 | 99 | 100 | 101 |
102 | 105 | 106 |
107 |
108 |
109 | 110 | -------------------------------------------------------------------------------- /attic/Examples/DistributedChat/DistributedChat.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fglasgow-exts -fth #-} 2 | module Main (main) where 3 | 4 | import Happstack.State 5 | import Happstack.Server 6 | 7 | import Data.Typeable ( Typeable ) 8 | import System.Environment ( getArgs, getProgName ) 9 | import System.Exit ( exitWith, ExitCode(ExitFailure) ) 10 | import Control.Monad.State ( put, get) 11 | import Control.Monad ( msum, mzero) 12 | import Control.Monad.Reader ( ask, liftM2, liftIO ) 13 | import Control.Exception ( bracket ) 14 | import Data.List ( intercalate ) 15 | import Data.Dynamic ( fromDynamic ) 16 | 17 | type Nick = String 18 | type Message = String 19 | type MessageId = Int 20 | 21 | data User = User { userNick :: Nick 22 | , userLastSeen :: MessageId } 23 | 24 | data ChatState = ChatState MessageId [ (Nick, Message, MessageId) ] deriving (Typeable) 25 | instance Version ChatState 26 | $(deriveSerialize ''ChatState) 27 | 28 | instance Component ChatState where 29 | type Dependencies ChatState = End 30 | initialValue = ChatState 2 [ ("System", "Welcome to the distributed chat system", 1) ] 31 | 32 | listMessages :: Query ChatState [(Nick, Message, MessageId)] 33 | listMessages = do ChatState _ msgs <- ask 34 | return msgs 35 | 36 | addMessage :: Nick -> Message -> Update ChatState () 37 | addMessage nick message 38 | = do ChatState mid msgs <- get 39 | put $ ChatState (mid+1) $ take 20 ((nick,message,mid):msgs) 40 | 41 | $(mkMethods ''ChatState [ 'listMessages, 'addMessage ]) 42 | 43 | -- Wait for a new message to appear. 44 | getMessages last 45 | = do stream <- getEventStream 46 | msgs <- query ListMessages 47 | case msgs of 48 | ((_,_,mid):_) | mid > last -> return (mid,msgs) 49 | _ -> do waitForAdd stream 50 | getMessages last 51 | where waitForAdd s = do ev <- s 52 | case fromDynamic (eventData ev) of 53 | Nothing -> waitForAdd s 54 | Just AddMessage{} -> return () 55 | 56 | rootState :: Proxy ChatState 57 | rootState = Proxy 58 | 59 | getUserFromCookie = liftM2 User (lookCookieValue "nick") (readCookieValue "last") 60 | 61 | getPort :: IO Int 62 | getPort = do args <- getArgs 63 | case args of 64 | [portStr] | [(port,"")] <- reads portStr -> return port 65 | _ -> do prog <- getProgName 66 | putStrLn $ "Usage: " ++ prog ++ " port" 67 | exitWith (ExitFailure 1) 68 | 69 | main :: IO () 70 | main = bracket (startSystemStateMultimaster rootState) closeTxControl $ \ctl -> 71 | do port <- getPort 72 | simpleHTTP nullConf{port=port} $ msum 73 | [ do 74 | mbUser <- getDataFn getUserFromCookie 75 | user <- maybe mzero return mbUser 76 | msum 77 | [ dir "send" $ do 78 | msg <- getDataFn (look "msg") >>= maybe mzero return 79 | update $ AddMessage (userNick user) msg 80 | ok (toResponse "OK") 81 | , dir "get" $ do 82 | (newLast, msgs) <- liftIO $ getMessages (userLastSeen user) 83 | addCookie (-1) (mkCookie "last" (show newLast)) 84 | ok (toResponse (format msgs)) 85 | 86 | , dir "clear" $ do 87 | addCookie (-1) (mkCookie "last" (show 0)) 88 | ok (toResponse "") 89 | , fileServe [] "ChatRun.html" 90 | ] 91 | , dir "login" $ do 92 | nick <- getDataFn (look "nick") >>= maybe mzero return 93 | addCookie (-1) (mkCookie "nick" nick) 94 | addCookie (-1) (mkCookie "last" (show 0)) 95 | seeOther "/" (toResponse "") 96 | , fileServe [] "ChatLogin.html" 97 | ] 98 | return () 99 | 100 | format = intercalate "
" . map fn 101 | where fn (nick, msg, mid) = nick ++ ": " ++ msg 102 | -------------------------------------------------------------------------------- /attic/Examples/DistributedChat/readme.txt: -------------------------------------------------------------------------------- 1 | How to run the distributed chat: 2 | 1. Compile two or more instances of the application 3 | ghc --make DistributedChat.hs -o chat1 4 | ghc --make DistributedChat.hs -o chat2 5 | 2. Make sure the spread daemon is running. 6 | /etc/init.d/spread start OR 7 | run spread manually 8 | 3. Execute the instances 9 | ./chat1 8000 10 | ./chat2 8001 11 | -------------------------------------------------------------------------------- /attic/Examples/MultimasterTest1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, DeriveDataTypeable, MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-} 2 | module Main where 3 | 4 | import Happstack.Server 5 | import Happstack.State 6 | 7 | import Data.Typeable 8 | import Control.Monad.State 9 | import Control.Monad.Reader 10 | 11 | data MyState = MyState Int deriving (Typeable) 12 | 13 | instance Version MyState 14 | $(deriveSerialize ''MyState) 15 | 16 | succVal :: Update MyState () 17 | succVal = modify (\(MyState n) -> MyState (succ n)) 18 | predVal :: Update MyState () 19 | predVal = modify (\(MyState n) -> MyState (pred n)) 20 | 21 | getVal :: Query MyState Int 22 | getVal = do MyState n <- ask 23 | return n 24 | 25 | $(mkMethods ''MyState [ 'succVal 26 | , 'predVal 27 | , 'getVal]) 28 | 29 | instance Component MyState where 30 | type Dependencies MyState = End 31 | initialValue = MyState 0 32 | 33 | rootState :: Proxy MyState 34 | rootState = Proxy 35 | 36 | main :: IO () 37 | main = do ctl <- startSystemStateMultimaster rootState 38 | simpleHTTP nullConf{port=8000} $ msum 39 | [ dir "succ" $ do update SuccVal 40 | seeOther "/" "" 41 | , dir "pred" $ do update PredVal 42 | seeOther "/" "" 43 | , do val <- query GetVal 44 | ok $ "Value is: " ++ show val ] 45 | 46 | -------------------------------------------------------------------------------- /attic/Examples/MultimasterTest2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, DeriveDataTypeable, MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-} 2 | module Main where 3 | 4 | import Happstack.Server 5 | import Happstack.State 6 | 7 | import Data.Typeable 8 | import Control.Monad.State 9 | import Control.Monad.Reader 10 | 11 | data MyState = MyState Int deriving (Typeable) 12 | instance Version MyState 13 | $(deriveSerialize ''MyState) 14 | 15 | succVal :: Update MyState () 16 | succVal = modify (\(MyState n) -> MyState (succ n)) 17 | predVal :: Update MyState () 18 | predVal = modify (\(MyState n) -> MyState (pred n)) 19 | 20 | getVal :: Query MyState Int 21 | getVal = do MyState n <- ask 22 | return n 23 | 24 | $(mkMethods ''MyState [ 'succVal 25 | , 'predVal 26 | , 'getVal]) 27 | 28 | instance Component MyState where 29 | type Dependencies MyState = End 30 | initialValue = MyState 0 31 | 32 | rootState :: Proxy MyState 33 | rootState = Proxy 34 | 35 | main :: IO () 36 | main = do ctl <- startSystemStateMultimaster rootState 37 | simpleHTTP nullConf{port=8001} $ msum 38 | [ dir "succ" $ do update SuccVal 39 | seeOther "/" "" 40 | , dir "pred" $ do update PredVal 41 | seeOther "/" "" 42 | , do val <- query GetVal 43 | ok $ "Value is: " ++ show val ] 44 | 45 | -------------------------------------------------------------------------------- /attic/Examples/Timer.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fth -fglasgow-exts -fallow-undecidable-instances #-} 2 | module Timer where 3 | 4 | import Happstack.State 5 | import Happstack.Data 6 | import Data.Typeable 7 | import Data.Generics 8 | import Control.Monad.State (modify) 9 | import Control.Concurrent 10 | 11 | newtype Timer = Timer Int deriving (Typeable) 12 | instance Version Timer 13 | $(deriveSerialize ''Timer) 14 | 15 | $(deriveNewData [''Timer]) 16 | 17 | tick () = modify $ \(Timer t) -> Timer (t+1) 18 | 19 | $(mkMethods ''Timer [ 'tick ] ) 20 | 21 | performTicks :: Proxy Timer -> IO () 22 | performTicks v = do update $ Tick () 23 | threadDelay (10^6) -- Once every 1 second 24 | performTicks v 25 | 26 | instance Component Timer where 27 | type Dependencies Timer = End 28 | initialValue = Timer 0 29 | -------------------------------------------------------------------------------- /attic/Examples/Validation.lhs: -------------------------------------------------------------------------------- 1 | > module Validation where 2 | 3 | > import Control.Concurrent 4 | > import Control.Monad(msum) 5 | > import Happstack.Server 6 | > import Text.XHtml hiding (dir,method) 7 | 8 | HAppS-Server has support for validating output on-the-fly. There are a 9 | few different ways you can use this system, depending on what your 10 | needs are. 11 | 12 | QuickStart 13 | ---------- 14 | 15 | The easiest option is to just use validateConf instead of nullConf: 16 | 17 | > ex1 = simpleHTTP validateConf $ msum [ dir "valid" $ methodM GET >> ok (toResponse validPage) 18 | > , dir "invalid" $ methodM GET >> ok (toResponse invalidPage) 19 | > , seeOther "/valid" (toResponse ()) 20 | > ] 21 | 22 | You will need WDG HTML Validator installed. It must be named 23 | 'validate' and it must be in the default PATH. On Debian systems you 24 | can just do: 25 | 26 | apt-get install wdg-html-validator. 27 | 28 | (NOTE: You must restart GHCi between runs because simpleHTTP forks 29 | off threads which don't get stopped when you hit ^C. These threads 30 | will contain to serve the old page instead of the new page.) 31 | 32 | The error page looks something like this: 33 | 34 | ----> 35 | ExitCode: ExitFailure 1 36 | stdout: 37 | Checking with XHTML 1.0 Transitional document type... 38 | *** Errors and warnings: *** 39 | -:5:3:E: end tag for "head" which is not finished 40 | 41 | stderr: 42 | 43 | input: 44 | 1 2 3 4 5 6 7 8 9 0 1 2 45 | 1 46 | 2 Hello, World! 53 | <-- 54 | 55 | How The System Works 56 | -------------------- 57 | 58 | Goals: 59 | 60 | 1. provide an easy way to have validation automatically enabled with no extra work from the developer 61 | 2. provide an easy way to disable validation for live sites 62 | 3. provide an easy way to selectively enable and disable validation for specific pages 63 | 4. privade an easy way to validate different content-types with different validators 64 | 5. provide an easy way to add new validators 65 | 66 | 67 | The solution involves two pieces working together: 68 | 69 | 1. the Conf datatype is extended to include an option for enabling validation and 70 | providing a default validator: 71 | 72 | data Conf 73 | = Conf { ... 74 | , validator :: Maybe (Response -> IO Response) 75 | , ... 76 | } 77 | 78 | 2. the Response datatype is also extended to include a validator 79 | field: 80 | 81 | data Response 82 | = Response { ... 83 | , rsValidator:: Maybe (Response -> IO Response) 84 | , ... 85 | } 86 | 87 | 88 | To enable validation, we must supply a default validator in the Conf 89 | we pass to simpleHTTP. If validator is Nothing, no validation will occur. 90 | 91 | The developer can just use validateConf instead of nullConf, and all 92 | of their HTML pages will be automatically validated. 93 | 94 | It is also easy to disable validation before making the site go 95 | live. You can either provide a command-line flag which sets the 96 | validator option in Conf to Nothing, or you can use CPP or Template 97 | Haskell to do it at compile time. 98 | 99 | Specifying a Specific Validator for a Specific Page 100 | --------------------------------------------------- 101 | 102 | Setting the validator to use for a particular Response is done using 103 | the 'setValidator' function. In this example, we enable validation, 104 | but then we turn it off for the invalidPage. (Do not forget to 105 | restart GHCi before running this example): 106 | 107 | > ex2 = simpleHTTP validateConf $ msum [ dir "valid" $ methodM GET >> ok (toResponse validPage) 108 | > , dir "invalid" $ methodM GET >> ok (setValidator noopValidator (toResponse invalidPage)) 109 | > , seeOther "/valid" (toResponse ()) 110 | > ] 111 | 112 | 113 | We can use setValidateSP to set the validator at the ServerPart 114 | level. This is useful if you have a whole subdirectory you wish to 115 | change the validator for. 116 | 117 | > ex3 = simpleHTTP validateConf $ setValidatorSP noopValidator $ msum 118 | > [ dir "valid" $ methodM GET >> ok (toResponse validPage) 119 | > , dir "invalid" $ methodM GET >> ok (toResponse invalidPage) 120 | > , seeOther "/valid" (toResponse ()) 121 | > ] 122 | 123 | Instead of validating all pages by default, and selectively disabling 124 | validation on some, we could enable validation, but only validate a 125 | few pages. 126 | 127 | We set the default validator to noopValidator, and then explicitly 128 | mark the pages we do want validated. In this example, /invalid will 129 | fail, but /invalid2 pass. 130 | 131 | > ex4 = simpleHTTP (nullConf { validator = Just noopValidator}) $ msum 132 | > [ dir "valid" $ methodM GET >> ok (toResponse validPage) 133 | > , dir "invalid" $ methodM GET >> ok (setValidator wdgHTMLValidator (toResponse invalidPage)) 134 | > , dir "invalid2" $ methodM GET >> ok (toResponse invalidPage) 135 | > , seeOther "/valid" (toResponse ()) 136 | > ] 137 | 138 | Per content-type validation 139 | --------------------------- 140 | 141 | Each validator should only attempt to validate content-types it 142 | understands, passing all other content-types through 143 | unmodified. Because the validator type is: 144 | 145 | Response -> IO Response 146 | 147 | This means we can simply chain validators together using >>=. 148 | 149 | > ex5 = simpleHTTP (nullConf { validator = Just $ \r -> noopValidator r >>= wdgHTMLValidator }) $ msum 150 | > [ dir "valid" $ methodM GET >> ok (toResponse validPage) 151 | > , dir "invalid" $ methodM GET >> ok (toResponse invalidPage) 152 | > , seeOther "/valid" (toResponse ()) 153 | > ] 154 | 155 | There is one caveat. Because we use >>= to chain the validators 156 | together, error messages produced by earlier validators will be 157 | validated by later validators. This is, perhaps, a good 158 | thing, as it can be used to detect errors in your error messages. 159 | 160 | Adding new validators 161 | --------------------- 162 | 163 | Adding a new validator is fairly straight forward: 164 | 165 | 1. it must have the type signature, Response -> IO Response 166 | 167 | 2. it should do, (getHeader "content-type" response), and only 168 | attempt to validate content-types it understands, passing all 169 | other types through unmodified. 170 | 171 | 3. it should leave the Response unmodified on success, or return a 172 | new Response with the error on the failure. 173 | 174 | If you intend to use an external program for validation, the easiest 175 | method is to use lazyProcValidator. For example, wdgHTMLValidator is 176 | essentially: 177 | 178 | wdgHTMLValidator :: Response -> IO Response 179 | wdgHTMLValidator = lazyProcValidator "validate" ["-w","--verbose"] Nothing Nothing handledContentTypes 180 | where 181 | handledContentTypes (Just ct) = elem (B.unpack ct) [ "text/html", "application/xhtml+xml" ] 182 | handledContentTypes Nothing = False 183 | 184 | Sample Pages 185 | ------------ 186 | 187 | These are just for use in the above examples. 188 | 189 | > validPage :: Html 190 | > validPage = 191 | > ((header << 192 | > thetitle (toHtml "Hello, World!") 193 | > ) +++ 194 | > (body << 195 | > (p << toHtml "Hello, World!" +++ 196 | > p << anchor ! [href "/invalid"] << (toHtml "invalid") 197 | > ) 198 | > )) 199 | 200 | > invalidPage :: Html 201 | > invalidPage = 202 | > ((header << noHtml 203 | > ) +++ 204 | > (body << 205 | > toHtml "Hello, World!" +++ 206 | > p << anchor ! [href "/valid"] << (toHtml "valid") 207 | > )) 208 | -------------------------------------------------------------------------------- /attic/Examples/dist-newstyle/cache/config: -------------------------------------------------------------------------------- 1 | packages: ./*.cabal 2 | optional-packages: ./*/*.cabal 3 | remote-repo-cache: /home/ramiro/.cabal/packages 4 | logs-dir: /home/ramiro/.cabal/logs 5 | world-file: /home/ramiro/.cabal/world 6 | verbose: 1 7 | solver: choose 8 | build-summary: /home/ramiro/.cabal/logs/build.log 9 | doc-index-file: $datadir/doc/$arch-$os-$compiler/index.html 10 | max-backjumps: 2000 11 | reorder-goals: False 12 | strong-flags: False 13 | remote-build-reporting: anonymous 14 | report-planning-failure: False 15 | one-shot: False 16 | jobs: $ncpus 17 | offline: False 18 | extra-prog-path: /home/ramiro/.cabal/bin 19 | compiler: ghc 20 | compiler: ghc 21 | documentation: False 22 | haddock-keep-temp-files: False 23 | haddock-hoogle: False 24 | haddock-html: False 25 | haddock-executables: False 26 | haddock-tests: False 27 | haddock-benchmarks: False 28 | haddock-internal: False 29 | haddock-hyperlink-source: False 30 | 31 | repository hackage.haskell.org 32 | url: http://hackage.haskell.org/ 33 | root-keys: fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0 34 | 1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42 35 | 2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3 36 | 0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d 37 | 51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921 38 | key-threshold: 3 39 | -------------------------------------------------------------------------------- /attic/Examples/set/FromData/Basics.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Happstack.Server 4 | import Control.Monad 5 | 6 | {- 7 | interesting urls: 8 | /?string=hello+world 9 | -} 10 | 11 | data MyStructure = MyStructure String 12 | instance FromData MyStructure where 13 | fromData = do str <- look "string" 14 | return $ MyStructure str 15 | 16 | main :: IO () 17 | main = do simpleHTTP nullConf $ msum 18 | [ 19 | do 20 | (MyStructure str) <- getData >>= maybe mzero return 21 | ok $ "You entered: " ++ str 22 | , ok "Sorry, I don't understand." 23 | ] 24 | 25 | -------------------------------------------------------------------------------- /attic/Examples/set/FromData/Cookies.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Happstack.Server 4 | import Control.Monad 5 | {- 6 | interesting urls: 7 | /setcookie/value 8 | /setcookie/hello+world 9 | -} 10 | 11 | data MyStructure = MyStructure String 12 | instance FromData MyStructure where 13 | fromData = do str <- lookCookieValue "cookie" 14 | return $ MyStructure str 15 | 16 | main :: IO () 17 | main = do simpleHTTP nullConf $ msum [ 18 | do (MyStructure str) <- getData >>= maybe mzero return 19 | ok $ "Cookie value: " ++ str 20 | , dir "setcookie" $ 21 | path $ \value -> 22 | do -- Create cookie with a duration of 30 seconds. 23 | addCookie 30 (mkCookie "cookie" value) 24 | ok "Cookie has been set" 25 | , ok "Try /setcookie/value" ] 26 | -------------------------------------------------------------------------------- /attic/Examples/set/FromData/Inline.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Happstack.Server 4 | import Control.Monad 5 | 6 | {- 7 | interesting urls: 8 | /?string=hello+world 9 | -} 10 | 11 | main :: IO () 12 | main = simpleHTTP nullConf $ msum 13 | [ 14 | do str <- getDataFn (look "string") >>= maybe mzero return 15 | ok $ "You entered: " ++ str 16 | , ok "Sorry, I don't understand." 17 | ] 18 | -------------------------------------------------------------------------------- /attic/Examples/set/FromData/Optional.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Happstack.Server 4 | import Data.Maybe 5 | 6 | {- 7 | interesting urls: 8 | /?string=hello+world 9 | /?string 10 | / 11 | -} 12 | 13 | data MyStructure = MyStructure {unpack :: String} 14 | instance FromData MyStructure where 15 | fromData = do str <- look "string" 16 | return $ MyStructure str 17 | main :: IO () 18 | main = simpleHTTP nullConf $ do 19 | mbStructure <- getData 20 | ok $ "Input: " ++ maybe "default value" unpack mbStructure 21 | -------------------------------------------------------------------------------- /attic/Examples/set/ServerPart/HelloWorld.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Happstack.Server 4 | 5 | {- 6 | interesting urls: 7 | / 8 | -} 9 | main :: IO () 10 | main = simpleHTTP nullConf $ ok "Hello World" 11 | 12 | -------------------------------------------------------------------------------- /attic/Examples/set/ServerPart/PathSegments.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Happstack.Server 4 | import Control.Monad 5 | 6 | {- 7 | interesting urls: 8 | /directory/ 9 | /any/foo 10 | /any/foo/bar 11 | /int/10 12 | /int/no-parse 13 | -} 14 | main :: IO () 15 | main = simpleHTTP nullConf $ msum 16 | [ dir "directory" $ ok "Inside directory" 17 | , dir "any" $ 18 | path $ \pathSegment -> 19 | ok $ "Path segment: " ++ pathSegment 20 | , dir "int" $ 21 | path $ \int -> 22 | ok $ "Integer segment: " ++ show (int::Int) 23 | , ok "Sorry, couldn't find a matching handler" ] 24 | -------------------------------------------------------------------------------- /attic/Examples/set/ServerPart/SideEffects.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Happstack.Server 4 | import Control.Monad 5 | import System.Directory 6 | 7 | {- 8 | interesting urls: 9 | / 10 | -} 11 | 12 | prog = "ghc" 13 | 14 | main :: IO () 15 | main = simpleHTTP nullConf $ msum 16 | [ requireM (findExecutable prog) $ \ghcPath -> 17 | ok $ prog ++ " path: " ++ ghcPath 18 | , ok $ "Sorry, couldn't find " ++ prog ] 19 | -------------------------------------------------------------------------------- /attic/Examples/set/Web/ControlFlow.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Happstack.Server 4 | import Control.Monad 5 | {- 6 | interesting urls: 7 | / 8 | /escape 9 | -} 10 | main :: IO () 11 | main = simpleHTTP nullConf $ 12 | do rq <- askRq 13 | unless (null $ rqPaths rq) $ escape $ seeOther "http://escape.com/" $ toResponse () 14 | ok "Hello World" 15 | 16 | -------------------------------------------------------------------------------- /attic/Examples/set/Web/ErrorCodes.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Happstack.Server 4 | import Control.Monad 5 | {- 6 | interesting urls: 7 | /badrequest 8 | /unauthorized 9 | /notfound 10 | /seeother 11 | /found 12 | /moved 13 | /tempredirect 14 | /set/404 15 | -} 16 | main :: IO () 17 | main = do simpleHTTP nullConf $ msum 18 | [ dir "badrequest" $ badRequest "badrequest" 19 | , dir "unauthorized" $ unauthorized "unauthorized" 20 | , dir "notfound" $ notFound "notfound" 21 | , dir "seeother" $ seeOther "/notfound/seeother" "" 22 | , dir "found" $ found "/notfound/found" "" 23 | , dir "moved" $ movedPermanently "/notfound/moved" "" 24 | , dir "tempredirect" $ tempRedirect "/notfound/tempredirect" "" 25 | , dir "set" $ 26 | path $ \errorCode -> 27 | do setResponseCode errorCode 28 | return $ "Error code: " ++ show errorCode 29 | ] 30 | -------------------------------------------------------------------------------- /attic/Examples/set/Web/FileServe.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Happstack.Server 4 | 5 | {- 6 | interesting urls: 7 | / 8 | /IO.hs 9 | /FileServe.hs 10 | -} 11 | main :: IO () 12 | main = simpleHTTP nullConf $ fileServe ["FileServe.hs"] "." 13 | -------------------------------------------------------------------------------- /attic/Examples/set/Web/IO.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Happstack.Server 4 | import System.Directory 5 | import Control.Monad.Trans 6 | 7 | {- 8 | interesting urls: 9 | / 10 | -} 11 | main :: IO () 12 | main = simpleHTTP nullConf $ 13 | do contents <- liftIO $ getDirectoryContents "." 14 | ok $ unlines contents 15 | -------------------------------------------------------------------------------- /attic/Examples/set/Web/Trace.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Main where 4 | 5 | import Happstack.Server 6 | import System.Directory 7 | import Control.Monad.Trans 8 | import Control.Monad.Writer 9 | import Control.Monad(msum) 10 | 11 | {- 12 | interesting urls: 13 | / 14 | /special/ 15 | /special/?query 16 | -} 17 | trace :: (Monad m, MonadWriter (Endo [String]) m) => String -> String -> m String 18 | trace name result = (tell $ Endo (name:)) >> return result 19 | 20 | transform :: (Monad m) => (WriterT (Endo [String]) m) (Maybe (Either Response String, FilterFun f)) 21 | -> m (Maybe (Either Response String, FilterFun f)) 22 | transform wt = do 23 | (res, t) <- runWriterT wt 24 | case res of 25 | Just (Right r, f) -> return $ Just (Right $ context t r,f) 26 | _ -> return res 27 | where context t r = "Context:\n\n" ++ unlines (reverse $ appEndo t []) ++ "\n\n" ++ show r 28 | 29 | main :: IO () 30 | main = do simpleHTTP' transform nullConf $ msum 31 | [ trace "special dir" =<< (dir "special" $ msum 32 | [ 33 | do mbStr <- getDataFn (look "query") 34 | str <- maybe mzero return mbStr 35 | trace "query" str 36 | 37 | ,trace "otherwise" =<< return "special" 38 | ]) 39 | 40 | ,trace "default" "default" 41 | ] 42 | -------------------------------------------------------------------------------- /attic/xslt/defaultStyle.xsl: -------------------------------------------------------------------------------- 1 | 2 | 5 | 6 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 |
27 | 28 | 31 |
32 | 33 |
34 | 37 | 38 |
39 | 40 | 41 | 42 | 43 | 44 | Default Title 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | <xsl:apply-templates mode="title" select="." /> 54 | 55 | 56 | 58 |