├── 10 ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── package.yaml ├── src │ ├── Adapter │ │ ├── HTTP │ │ │ ├── API │ │ │ │ ├── Client │ │ │ │ │ ├── Auth.hs │ │ │ │ │ └── Common.hs │ │ │ │ ├── Server │ │ │ │ │ ├── Auth.hs │ │ │ │ │ ├── Common.hs │ │ │ │ │ └── Main.hs │ │ │ │ └── Types │ │ │ │ │ ├── AesonHelper.hs │ │ │ │ │ └── Auth.hs │ │ │ ├── Common.hs │ │ │ ├── Main.hs │ │ │ └── Web │ │ │ │ ├── Auth.hs │ │ │ │ ├── Common.hs │ │ │ │ ├── Main.hs │ │ │ │ └── static │ │ │ │ └── images │ │ │ │ └── logo.png │ │ ├── InMemory │ │ │ └── Auth.hs │ │ ├── PostgreSQL │ │ │ ├── Auth.hs │ │ │ └── Migrations │ │ │ │ └── 00000_auths.sql │ │ ├── RabbitMQ │ │ │ ├── Auth.hs │ │ │ └── Common.hs │ │ └── Redis │ │ │ └── Auth.hs │ ├── Config.hs │ ├── Domain │ │ ├── Auth.hs │ │ └── Validation.hs │ └── Lib.hs ├── stack.yaml └── test │ └── Spec.hs ├── 11 ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── package.yaml ├── src │ ├── Adapter │ │ ├── HTTP │ │ │ ├── API │ │ │ │ ├── Client │ │ │ │ │ ├── Auth.hs │ │ │ │ │ └── Common.hs │ │ │ │ ├── Server │ │ │ │ │ ├── Auth.hs │ │ │ │ │ ├── Common.hs │ │ │ │ │ └── Main.hs │ │ │ │ └── Types │ │ │ │ │ ├── AesonHelper.hs │ │ │ │ │ └── Auth.hs │ │ │ ├── Common.hs │ │ │ ├── Main.hs │ │ │ └── Web │ │ │ │ ├── Auth.hs │ │ │ │ ├── Common.hs │ │ │ │ ├── Main.hs │ │ │ │ └── static │ │ │ │ └── images │ │ │ │ └── logo.png │ │ ├── InMemory │ │ │ └── Auth.hs │ │ ├── PostgreSQL │ │ │ ├── Auth.hs │ │ │ └── Migrations │ │ │ │ └── 00000_auths.sql │ │ ├── RabbitMQ │ │ │ ├── Auth.hs │ │ │ └── Common.hs │ │ └── Redis │ │ │ └── Auth.hs │ ├── Config.hs │ ├── Domain │ │ ├── Auth │ │ │ ├── Service.hs │ │ │ └── Types.hs │ │ └── Validation.hs │ └── Lib.hs ├── stack.yaml └── test │ ├── Adapter │ ├── HTTP │ │ ├── API │ │ │ └── Server │ │ │ │ └── AuthSpec.hs │ │ └── Fixture.hs │ ├── PostgreSQL │ │ └── AuthSpec.hs │ ├── RabbitMQ │ │ └── AuthSpec.hs │ └── Redis │ │ └── AuthSpec.hs │ ├── ConfigSpec.hs │ ├── Domain │ ├── Auth │ │ ├── ServiceSpec.hs │ │ └── TypesSpec.hs │ └── ValidationSpec.hs │ ├── Fixture.hs │ └── Spec.hs ├── 12 ├── .gitignore ├── .hlint.yaml ├── .hpc-threshold ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── build.sh ├── package.yaml ├── scripts │ ├── Dockerfile │ ├── build-docker.sh │ └── docker-compose.yml ├── src │ ├── Adapter │ │ ├── HTTP │ │ │ ├── API │ │ │ │ ├── Client │ │ │ │ │ ├── Auth.hs │ │ │ │ │ └── Common.hs │ │ │ │ ├── Server │ │ │ │ │ ├── Auth.hs │ │ │ │ │ ├── Common.hs │ │ │ │ │ └── Main.hs │ │ │ │ └── Types │ │ │ │ │ ├── AesonHelper.hs │ │ │ │ │ └── Auth.hs │ │ │ ├── Common.hs │ │ │ ├── Main.hs │ │ │ └── Web │ │ │ │ ├── Auth.hs │ │ │ │ ├── Common.hs │ │ │ │ ├── Main.hs │ │ │ │ └── static │ │ │ │ └── images │ │ │ │ └── logo.png │ │ ├── InMemory │ │ │ └── Auth.hs │ │ ├── PostgreSQL │ │ │ ├── Auth.hs │ │ │ └── Migrations │ │ │ │ └── 00000_auths.sql │ │ ├── RabbitMQ │ │ │ ├── Auth.hs │ │ │ └── Common.hs │ │ └── Redis │ │ │ └── Auth.hs │ ├── Config.hs │ ├── Domain │ │ ├── Auth │ │ │ ├── Service.hs │ │ │ └── Types.hs │ │ └── Validation.hs │ └── Lib.hs ├── stack.yaml └── test │ ├── Adapter │ ├── HTTP │ │ ├── API │ │ │ └── Server │ │ │ │ └── AuthSpec.hs │ │ └── Fixture.hs │ ├── PostgreSQL │ │ └── AuthSpec.hs │ ├── RabbitMQ │ │ └── AuthSpec.hs │ └── Redis │ │ └── AuthSpec.hs │ ├── ConfigSpec.hs │ ├── Domain │ ├── Auth │ │ ├── ServiceSpec.hs │ │ └── TypesSpec.hs │ └── ValidationSpec.hs │ ├── Fixture.hs │ └── Spec.hs ├── .gitattributes ├── 01 ├── Figure_1-1.png ├── Figure_1-2.png └── Figure_1-3.png ├── 02 ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── package.yaml ├── src │ └── Lib.hs ├── stack.yaml └── test │ └── Spec.hs ├── 03 ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── package.yaml ├── src │ ├── Adapter │ │ └── InMemory │ │ │ └── Auth.hs │ ├── Domain │ │ ├── Auth.hs │ │ └── Validation.hs │ └── Lib.hs ├── stack.yaml └── test │ └── Spec.hs ├── 04 ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── package.yaml ├── src │ ├── Adapter │ │ └── InMemory │ │ │ └── Auth.hs │ ├── Domain │ │ ├── Auth.hs │ │ └── Validation.hs │ └── Lib.hs ├── stack.yaml └── test │ └── Spec.hs ├── 05 ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── package.yaml ├── src │ ├── Adapter │ │ ├── InMemory │ │ │ └── Auth.hs │ │ ├── PostgreSQL │ │ │ ├── Auth.hs │ │ │ └── Migrations │ │ │ │ └── 00000_auths.sql │ │ └── Redis │ │ │ └── Auth.hs │ ├── Domain │ │ ├── Auth.hs │ │ └── Validation.hs │ └── Lib.hs ├── stack.yaml └── test │ └── Spec.hs ├── 06 ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── package.yaml ├── src │ ├── Adapter │ │ ├── InMemory │ │ │ └── Auth.hs │ │ ├── PostgreSQL │ │ │ ├── Auth.hs │ │ │ └── Migrations │ │ │ │ └── 00000_auths.sql │ │ ├── RabbitMQ │ │ │ ├── Auth.hs │ │ │ └── Common.hs │ │ └── Redis │ │ │ └── Auth.hs │ ├── Domain │ │ ├── Auth.hs │ │ └── Validation.hs │ └── Lib.hs ├── stack.yaml └── test │ └── Spec.hs ├── 07 ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── package.yaml ├── src │ ├── Adapter │ │ ├── HTTP │ │ │ ├── API │ │ │ │ └── Auth.hs │ │ │ ├── Common.hs │ │ │ └── Main.hs │ │ ├── InMemory │ │ │ └── Auth.hs │ │ ├── PostgreSQL │ │ │ ├── Auth.hs │ │ │ └── Migrations │ │ │ │ └── 00000_auths.sql │ │ ├── RabbitMQ │ │ │ ├── Auth.hs │ │ │ └── Common.hs │ │ └── Redis │ │ │ └── Auth.hs │ ├── Domain │ │ ├── Auth.hs │ │ └── Validation.hs │ └── Lib.hs ├── stack.yaml └── test │ └── Spec.hs ├── 08 ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── package.yaml ├── src │ ├── Adapter │ │ ├── HTTP │ │ │ ├── API │ │ │ │ ├── Auth.hs │ │ │ │ ├── Common.hs │ │ │ │ └── Main.hs │ │ │ ├── Common.hs │ │ │ ├── Main.hs │ │ │ └── Web │ │ │ │ ├── Auth.hs │ │ │ │ ├── Common.hs │ │ │ │ ├── Main.hs │ │ │ │ └── static │ │ │ │ └── images │ │ │ │ └── logo.png │ │ ├── InMemory │ │ │ └── Auth.hs │ │ ├── PostgreSQL │ │ │ ├── Auth.hs │ │ │ └── Migrations │ │ │ │ └── 00000_auths.sql │ │ ├── RabbitMQ │ │ │ ├── Auth.hs │ │ │ └── Common.hs │ │ └── Redis │ │ │ └── Auth.hs │ ├── Domain │ │ ├── Auth.hs │ │ └── Validation.hs │ └── Lib.hs ├── stack.yaml └── test │ └── Spec.hs ├── 09 ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app │ └── Main.hs ├── package.yaml ├── src │ ├── Adapter │ │ ├── HTTP │ │ │ ├── API │ │ │ │ ├── Client │ │ │ │ │ ├── Auth.hs │ │ │ │ │ └── Common.hs │ │ │ │ ├── Server │ │ │ │ │ ├── Auth.hs │ │ │ │ │ ├── Common.hs │ │ │ │ │ └── Main.hs │ │ │ │ └── Types │ │ │ │ │ ├── AesonHelper.hs │ │ │ │ │ └── Auth.hs │ │ │ ├── Common.hs │ │ │ ├── Main.hs │ │ │ └── Web │ │ │ │ ├── Auth.hs │ │ │ │ ├── Common.hs │ │ │ │ ├── Main.hs │ │ │ │ └── static │ │ │ │ └── images │ │ │ │ └── logo.png │ │ ├── InMemory │ │ │ └── Auth.hs │ │ ├── PostgreSQL │ │ │ ├── Auth.hs │ │ │ └── Migrations │ │ │ │ └── 00000_auths.sql │ │ ├── RabbitMQ │ │ │ ├── Auth.hs │ │ │ └── Common.hs │ │ └── Redis │ │ │ └── Auth.hs │ ├── Domain │ │ ├── Auth.hs │ │ └── Validation.hs │ └── Lib.hs ├── stack.yaml └── test │ └── Spec.hs ├── 9781484237380.jpg ├── Contributing.md ├── LICENSE.txt └── README.md /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | -------------------------------------------------------------------------------- /01/Figure_1-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-webdev-haskell/17b90c06030def254bb0497b9e357f5d3b96d0cf/01/Figure_1-1.png -------------------------------------------------------------------------------- /01/Figure_1-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-webdev-haskell/17b90c06030def254bb0497b9e357f5d3b96d0cf/01/Figure_1-2.png -------------------------------------------------------------------------------- /01/Figure_1-3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-webdev-haskell/17b90c06030def254bb0497b9e357f5d3b96d0cf/01/Figure_1-3.png -------------------------------------------------------------------------------- /02/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | .hspec-failures 3 | *.tix 4 | .DS_Store 5 | *.cabal 6 | -------------------------------------------------------------------------------- /02/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 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 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /02/README.md: -------------------------------------------------------------------------------- 1 | # hauth 2 | -------------------------------------------------------------------------------- /02/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /02/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ClassyPrelude 4 | import Lib 5 | 6 | main :: IO () 7 | main = someFunc 8 | -------------------------------------------------------------------------------- /02/package.yaml: -------------------------------------------------------------------------------- 1 | name: hauth 2 | version: '0.1.0.0' 3 | category: Web 4 | author: Ecky Putrady 5 | maintainer: eckyp@example.com 6 | copyright: 2017 Ecky Putrady 7 | license: BSD3 8 | github: githubuser/hauth 9 | extra-source-files: 10 | - README.md 11 | 12 | dependencies: 13 | - base 14 | - classy-prelude 15 | - pcre-heavy 16 | - time-lens 17 | - time 18 | - aeson 19 | 20 | default-extensions: 21 | - NoImplicitPrelude 22 | - OverloadedStrings 23 | - QuasiQuotes 24 | - TemplateHaskell 25 | 26 | library: 27 | source-dirs: src 28 | dependencies: 29 | executables: 30 | hauth-exe: 31 | main: Main.hs 32 | source-dirs: app 33 | ghc-options: 34 | - -threaded 35 | - -rtsopts 36 | - -with-rtsopts=-N 37 | dependencies: 38 | - hauth 39 | tests: 40 | hauth-test: 41 | main: Spec.hs 42 | source-dirs: test 43 | ghc-options: 44 | - -threaded 45 | - -rtsopts 46 | - -with-rtsopts=-N 47 | dependencies: 48 | - hauth 49 | -------------------------------------------------------------------------------- /02/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | import ClassyPrelude 6 | 7 | someFunc :: IO () 8 | someFunc = putStrLn "someFunc" -------------------------------------------------------------------------------- /02/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-9.11 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.5" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /02/test/Spec.hs: -------------------------------------------------------------------------------- 1 | import ClassyPrelude 2 | 3 | main :: IO () 4 | main = putStrLn "Test suite not yet implemented" 5 | -------------------------------------------------------------------------------- /03/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | .hspec-failures 3 | *.tix 4 | .DS_Store 5 | *.cabal 6 | -------------------------------------------------------------------------------- /03/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 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 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /03/README.md: -------------------------------------------------------------------------------- 1 | # hauth 2 | -------------------------------------------------------------------------------- /03/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /03/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ClassyPrelude 4 | import Lib 5 | 6 | main :: IO () 7 | main = someFunc 8 | -------------------------------------------------------------------------------- /03/package.yaml: -------------------------------------------------------------------------------- 1 | name: hauth 2 | version: '0.1.0.0' 3 | category: Web 4 | author: Ecky Putrady 5 | maintainer: eckyp@example.com 6 | copyright: 2017 Ecky Putrady 7 | license: BSD3 8 | github: githubuser/hauth 9 | extra-source-files: 10 | - README.md 11 | 12 | dependencies: 13 | - base 14 | - classy-prelude 15 | - pcre-heavy 16 | - time-lens 17 | - time 18 | - aeson 19 | - mtl 20 | - string-random 21 | - data-has 22 | 23 | default-extensions: 24 | - NoImplicitPrelude 25 | - OverloadedStrings 26 | - QuasiQuotes 27 | - GeneralizedNewtypeDeriving 28 | - ConstraintKinds 29 | - FlexibleContexts 30 | 31 | library: 32 | source-dirs: src 33 | executables: 34 | hauth-exe: 35 | main: Main.hs 36 | source-dirs: app 37 | ghc-options: 38 | - -threaded 39 | - -rtsopts 40 | - -with-rtsopts=-N 41 | dependencies: 42 | - hauth 43 | tests: 44 | hauth-test: 45 | main: Spec.hs 46 | source-dirs: test 47 | ghc-options: 48 | - -threaded 49 | - -rtsopts 50 | - -with-rtsopts=-N 51 | dependencies: 52 | - hauth 53 | -------------------------------------------------------------------------------- /03/src/Domain/Validation.hs: -------------------------------------------------------------------------------- 1 | module Domain.Validation where 2 | 3 | import ClassyPrelude 4 | import Text.Regex.PCRE.Heavy 5 | 6 | type Validation e a = a -> Maybe e 7 | 8 | validate :: (a -> b) -> [Validation e a] -> a -> Either [e] b 9 | validate constructor validations val = 10 | case concatMap (\f -> maybeToList $ f val) validations of 11 | [] -> Right $ constructor val 12 | errs -> Left errs 13 | 14 | rangeBetween :: (Ord a) => a -> a -> e -> Validation e a 15 | rangeBetween minRange maxRange msg val = 16 | if val >= minRange && val <= maxRange then Nothing else Just msg 17 | 18 | lengthBetween :: (MonoFoldable a) => Int -> Int -> e -> Validation e a 19 | lengthBetween minLen maxLen msg val = 20 | rangeBetween minLen maxLen msg (length val) 21 | 22 | regexMatches :: Regex -> e -> Validation e Text 23 | regexMatches regex msg val = 24 | if val =~ regex then Nothing else Just msg 25 | -------------------------------------------------------------------------------- /03/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | import ClassyPrelude 6 | import qualified Adapter.InMemory.Auth as M 7 | import Domain.Auth 8 | 9 | type State = TVar M.State 10 | newtype App a = App 11 | { unApp :: ReaderT State IO a 12 | } deriving (Applicative, Functor, Monad, MonadReader State, MonadIO) 13 | 14 | run :: State -> App a -> IO a 15 | run state = flip runReaderT state . unApp 16 | 17 | instance AuthRepo App where 18 | addAuth = M.addAuth 19 | setEmailAsVerified = M.setEmailAsVerified 20 | findUserByAuth = M.findUserByAuth 21 | findEmailFromUserId = M.findEmailFromUserId 22 | 23 | instance EmailVerificationNotif App where 24 | notifyEmailVerification = M.notifyEmailVerification 25 | 26 | instance SessionRepo App where 27 | newSession = M.newSession 28 | findUserIdBySessionId = M.findUserIdBySessionId 29 | 30 | someFunc :: IO () 31 | someFunc = do 32 | state <- newTVarIO M.initialState 33 | run state action 34 | 35 | action :: App () 36 | action = do 37 | let email = either undefined id $ mkEmail "ecky@test.com" 38 | passw = either undefined id $ mkPassword "1234ABCDefgh" 39 | auth = Auth email passw 40 | register auth 41 | Just vCode <- M.getNotificationsForEmail email 42 | verifyEmail vCode 43 | Right session <- login auth 44 | Just uId <- resolveSessionId session 45 | Just registeredEmail <- getUser uId 46 | print (session, uId, registeredEmail) 47 | -------------------------------------------------------------------------------- /03/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-9.11 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: 43 | - string-random-0.1.0.0 44 | 45 | # Override default flag values for local packages and extra-deps 46 | flags: {} 47 | 48 | # Extra package databases containing global packages 49 | extra-package-dbs: [] 50 | 51 | # Control whether we use the GHC we find on the path 52 | # system-ghc: true 53 | # 54 | # Require a specific version of stack, using version ranges 55 | # require-stack-version: -any # Default 56 | # require-stack-version: ">=1.5" 57 | # 58 | # Override the architecture used by stack, especially useful on Windows 59 | # arch: i386 60 | # arch: x86_64 61 | # 62 | # Extra directories used by stack for building 63 | # extra-include-dirs: [/path/to/dir] 64 | # extra-lib-dirs: [/path/to/dir] 65 | # 66 | # Allow a newer minor version of GHC than the snapshot specifies 67 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /03/test/Spec.hs: -------------------------------------------------------------------------------- 1 | import ClassyPrelude 2 | 3 | main :: IO () 4 | main = putStrLn "Test suite not yet implemented" 5 | -------------------------------------------------------------------------------- /04/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | .hspec-failures 3 | *.tix 4 | .DS_Store 5 | *.cabal 6 | -------------------------------------------------------------------------------- /04/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 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 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /04/README.md: -------------------------------------------------------------------------------- 1 | # hauth 2 | -------------------------------------------------------------------------------- /04/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /04/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ClassyPrelude 4 | import Lib 5 | 6 | main :: IO () 7 | main = someFunc 8 | -------------------------------------------------------------------------------- /04/package.yaml: -------------------------------------------------------------------------------- 1 | name: hauth 2 | version: '0.1.0.0' 3 | category: Web 4 | author: Ecky Putrady 5 | maintainer: eckyp@example.com 6 | copyright: 2017 Ecky Putrady 7 | license: BSD3 8 | github: githubuser/hauth 9 | extra-source-files: 10 | - README.md 11 | 12 | dependencies: 13 | - base 14 | - classy-prelude 15 | - pcre-heavy 16 | - time-lens 17 | - time 18 | - aeson 19 | - mtl 20 | - string-random 21 | - data-has 22 | - katip 23 | 24 | default-extensions: 25 | - NoImplicitPrelude 26 | - OverloadedStrings 27 | - QuasiQuotes 28 | - GeneralizedNewtypeDeriving 29 | - ConstraintKinds 30 | - FlexibleContexts 31 | - TemplateHaskell 32 | 33 | library: 34 | source-dirs: src 35 | dependencies: 36 | executables: 37 | hauth-exe: 38 | main: Main.hs 39 | source-dirs: app 40 | ghc-options: 41 | - -threaded 42 | - -rtsopts 43 | - -with-rtsopts=-N 44 | dependencies: 45 | - hauth 46 | tests: 47 | hauth-test: 48 | main: Spec.hs 49 | source-dirs: test 50 | ghc-options: 51 | - -threaded 52 | - -rtsopts 53 | - -with-rtsopts=-N 54 | dependencies: 55 | - hauth 56 | -------------------------------------------------------------------------------- /04/src/Domain/Validation.hs: -------------------------------------------------------------------------------- 1 | module Domain.Validation where 2 | 3 | import ClassyPrelude 4 | import Text.Regex.PCRE.Heavy 5 | 6 | type ErrMsg = Text 7 | type Validation a = a -> Maybe ErrMsg 8 | 9 | validate :: (a -> b) -> [Validation a] -> a -> Either [ErrMsg] b 10 | validate constructor validations val = 11 | case concatMap (\f -> maybeToList $ f val) validations of 12 | [] -> Right $ constructor val 13 | errs -> Left errs 14 | 15 | rangeBetween :: (Ord a) => a -> a -> ErrMsg -> Validation a 16 | rangeBetween minRange maxRange msg val = 17 | if val >= minRange && val <= maxRange then Nothing else Just msg 18 | 19 | lengthBetween :: (MonoFoldable a) => Int -> Int -> ErrMsg -> Validation a 20 | lengthBetween minLen maxLen msg val = 21 | rangeBetween minLen maxLen msg (length val) 22 | 23 | regexMatches :: Regex -> ErrMsg -> Validation Text 24 | regexMatches regex msg val = 25 | if val =~ regex then Nothing else Just msg 26 | -------------------------------------------------------------------------------- /04/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | import ClassyPrelude 6 | import qualified Adapter.InMemory.Auth as M 7 | import Domain.Auth 8 | import Katip 9 | 10 | type State = TVar M.State 11 | newtype App a = App 12 | { unApp :: ReaderT State (KatipContextT IO) a 13 | } deriving ( Applicative, Functor, Monad, MonadReader State, MonadIO 14 | , KatipContext, Katip) 15 | 16 | run :: LogEnv -> State -> App a -> IO a 17 | run le state 18 | = runKatipContextT le () mempty 19 | . flip runReaderT state 20 | . unApp 21 | 22 | instance AuthRepo App where 23 | addAuth = M.addAuth 24 | setEmailAsVerified = M.setEmailAsVerified 25 | findUserByAuth = M.findUserByAuth 26 | findEmailFromUserId = M.findEmailFromUserId 27 | 28 | instance EmailVerificationNotif App where 29 | notifyEmailVerification = M.notifyEmailVerification 30 | 31 | instance SessionRepo App where 32 | newSession = M.newSession 33 | findUserIdBySessionId = M.findUserIdBySessionId 34 | 35 | withKatip :: (LogEnv -> IO a) -> IO a 36 | withKatip app = 37 | bracket createLogEnv closeScribes app 38 | where 39 | createLogEnv = do 40 | logEnv <- initLogEnv "HAuth" "prod" 41 | stdoutScribe <- mkHandleScribe ColorIfTerminal stdout InfoS V2 42 | registerScribe "stdout" stdoutScribe defaultScribeSettings logEnv 43 | 44 | someFunc :: IO () 45 | someFunc = withKatip $ \le -> do 46 | state <- newTVarIO M.initialState 47 | run le state action 48 | 49 | action :: App () 50 | action = do 51 | let email = either undefined id $ mkEmail "ecky@test.com" 52 | passw = either undefined id $ mkPassword "1234ABCDefgh" 53 | auth = Auth email passw 54 | register auth 55 | Just vCode <- M.getNotificationsForEmail email 56 | verifyEmail vCode 57 | Right session <- login auth 58 | Just uId <- resolveSessionId session 59 | Just registeredEmail <- getUser uId 60 | print (session, uId, registeredEmail) 61 | 62 | -------------------------------------------------------------------------------- /04/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-9.11 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: 43 | - string-random-0.1.0.0 44 | 45 | # Override default flag values for local packages and extra-deps 46 | flags: {} 47 | 48 | # Extra package databases containing global packages 49 | extra-package-dbs: [] 50 | 51 | # Control whether we use the GHC we find on the path 52 | # system-ghc: true 53 | # 54 | # Require a specific version of stack, using version ranges 55 | # require-stack-version: -any # Default 56 | # require-stack-version: ">=1.5" 57 | # 58 | # Override the architecture used by stack, especially useful on Windows 59 | # arch: i386 60 | # arch: x86_64 61 | # 62 | # Extra directories used by stack for building 63 | # extra-include-dirs: [/path/to/dir] 64 | # extra-lib-dirs: [/path/to/dir] 65 | # 66 | # Allow a newer minor version of GHC than the snapshot specifies 67 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /04/test/Spec.hs: -------------------------------------------------------------------------------- 1 | import ClassyPrelude 2 | 3 | main :: IO () 4 | main = putStrLn "Test suite not yet implemented" 5 | -------------------------------------------------------------------------------- /05/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | .hspec-failures 3 | *.tix 4 | .DS_Store 5 | *.cabal 6 | -------------------------------------------------------------------------------- /05/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 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 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /05/README.md: -------------------------------------------------------------------------------- 1 | # hauth 2 | -------------------------------------------------------------------------------- /05/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /05/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ClassyPrelude 4 | import Lib 5 | 6 | main :: IO () 7 | main = someFunc 8 | -------------------------------------------------------------------------------- /05/package.yaml: -------------------------------------------------------------------------------- 1 | name: hauth 2 | version: '0.1.0.0' 3 | category: Web 4 | author: Ecky Putrady 5 | maintainer: eckyp@example.com 6 | copyright: 2017 Ecky Putrady 7 | license: BSD3 8 | github: githubuser/hauth 9 | extra-source-files: 10 | - README.md 11 | 12 | dependencies: 13 | - base 14 | - classy-prelude 15 | - pcre-heavy 16 | - time-lens 17 | - time 18 | - aeson 19 | - mtl 20 | - string-random 21 | - data-has 22 | - katip 23 | - postgresql-simple 24 | - postgresql-simple-migration 25 | - resource-pool 26 | - hedis 27 | 28 | default-extensions: 29 | - NoImplicitPrelude 30 | - OverloadedStrings 31 | - QuasiQuotes 32 | - GeneralizedNewtypeDeriving 33 | - ConstraintKinds 34 | - FlexibleContexts 35 | - TemplateHaskell 36 | 37 | library: 38 | source-dirs: src 39 | executables: 40 | hauth-exe: 41 | main: Main.hs 42 | source-dirs: app 43 | ghc-options: 44 | - -threaded 45 | - -rtsopts 46 | - -with-rtsopts=-N 47 | dependencies: 48 | - hauth 49 | tests: 50 | hauth-test: 51 | main: Spec.hs 52 | source-dirs: test 53 | ghc-options: 54 | - -threaded 55 | - -rtsopts 56 | - -with-rtsopts=-N 57 | dependencies: 58 | - hauth 59 | -------------------------------------------------------------------------------- /05/src/Adapter/PostgreSQL/Migrations/00000_auths.sql: -------------------------------------------------------------------------------- 1 | create extension citext; 2 | create extension pgcrypto; 3 | 4 | create table auths ( 5 | id bigserial primary key not null, 6 | pass text not null, 7 | email citext not null unique, 8 | email_verification_code text not null, 9 | is_email_verified boolean not null 10 | ); -------------------------------------------------------------------------------- /05/src/Adapter/Redis/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Redis.Auth where 2 | 3 | import ClassyPrelude 4 | import qualified Domain.Auth as D 5 | import Text.StringRandom 6 | import Data.Has 7 | import qualified Database.Redis as R 8 | 9 | type State = R.Connection 10 | 11 | type Redis r m = (Has State r, MonadReader r m, MonadIO m, MonadThrow m) 12 | 13 | -- | Create state from redis url string. 14 | -- format: redis://user:pass@host:port/db 15 | -- sample: redis://abc:def@localhost:6379/0 16 | withState :: String -> (State -> IO a) -> IO a 17 | withState connUrl action = 18 | case R.parseConnectInfo connUrl of 19 | Left _ -> 20 | throwString $ "Invalid Redis conn URL: " <> connUrl 21 | Right connInfo -> do 22 | conn <- R.checkedConnect connInfo 23 | action conn 24 | 25 | withConn :: Redis r m => R.Redis a -> m a 26 | withConn action = do 27 | conn <- asks getter 28 | liftIO $ R.runRedis conn action 29 | 30 | newSession :: Redis r m => D.UserId -> m D.SessionId 31 | newSession userId = do 32 | sId <- liftIO $ stringRandomIO "[a-zA-Z0-9]{32}" 33 | result <- withConn $ R.set (encodeUtf8 sId) (fromString . show $ userId) 34 | case result of 35 | Right R.Ok -> return sId 36 | err -> throwString $ "Unexpected redis error: " <> show err 37 | 38 | findUserIdBySessionId :: Redis r m => D.SessionId -> m (Maybe D.UserId) 39 | findUserIdBySessionId sId = do 40 | result <- withConn $ R.get (encodeUtf8 sId) 41 | return $ case result of 42 | Right (Just uIdStr) -> readMay . unpack . decodeUtf8 $ uIdStr 43 | err -> throwString $ "Unexpected redis error: " <> show err -------------------------------------------------------------------------------- /05/src/Domain/Validation.hs: -------------------------------------------------------------------------------- 1 | module Domain.Validation where 2 | 3 | import ClassyPrelude 4 | import Text.Regex.PCRE.Heavy 5 | 6 | type ErrMsg = Text 7 | type Validation a = a -> Maybe ErrMsg 8 | 9 | validate :: (a -> b) -> [Validation a] -> a -> Either [ErrMsg] b 10 | validate constructor validations val = 11 | case concatMap (\f -> maybeToList $ f val) validations of 12 | [] -> Right $ constructor val 13 | errs -> Left errs 14 | 15 | rangeBetween :: (Ord a) => a -> a -> ErrMsg -> Validation a 16 | rangeBetween minRange maxRange msg val = 17 | if val >= minRange && val <= maxRange then Nothing else Just msg 18 | 19 | lengthBetween :: (MonoFoldable a) => Int -> Int -> ErrMsg -> Validation a 20 | lengthBetween minLen maxLen msg val = 21 | rangeBetween minLen maxLen msg (length val) 22 | 23 | regexMatches :: Regex -> ErrMsg -> Validation Text 24 | regexMatches regex msg val = 25 | if val =~ regex then Nothing else Just msg 26 | -------------------------------------------------------------------------------- /05/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-10.3 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: 43 | - string-random-0.1.0.0 44 | - hedis-0.10.0 45 | 46 | # Override default flag values for local packages and extra-deps 47 | flags: {} 48 | 49 | # Extra package databases containing global packages 50 | extra-package-dbs: [] 51 | 52 | # Control whether we use the GHC we find on the path 53 | # system-ghc: true 54 | # 55 | # Require a specific version of stack, using version ranges 56 | # require-stack-version: -any # Default 57 | # require-stack-version: ">=1.5" 58 | # 59 | # Override the architecture used by stack, especially useful on Windows 60 | # arch: i386 61 | # arch: x86_64 62 | # 63 | # Extra directories used by stack for building 64 | # extra-include-dirs: [/path/to/dir] 65 | # extra-lib-dirs: [/path/to/dir] 66 | # 67 | # Allow a newer minor version of GHC than the snapshot specifies 68 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /05/test/Spec.hs: -------------------------------------------------------------------------------- 1 | import ClassyPrelude 2 | 3 | main :: IO () 4 | main = putStrLn "Test suite not yet implemented" 5 | -------------------------------------------------------------------------------- /06/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | .hspec-failures 3 | *.tix 4 | .DS_Store 5 | *.cabal 6 | -------------------------------------------------------------------------------- /06/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 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 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /06/README.md: -------------------------------------------------------------------------------- 1 | # hauth 2 | -------------------------------------------------------------------------------- /06/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /06/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ClassyPrelude 4 | import qualified Lib as Lib 5 | 6 | main :: IO () 7 | main = Lib.main 8 | -------------------------------------------------------------------------------- /06/package.yaml: -------------------------------------------------------------------------------- 1 | name: hauth 2 | version: '0.1.0.0' 3 | category: Web 4 | author: Ecky Putrady 5 | maintainer: eckyp@example.com 6 | copyright: 2017 Ecky Putrady 7 | license: BSD3 8 | github: githubuser/hauth 9 | extra-source-files: 10 | - README.md 11 | 12 | dependencies: 13 | - base 14 | - classy-prelude 15 | - pcre-heavy 16 | - time-lens 17 | - time 18 | - aeson 19 | - mtl 20 | - string-random 21 | - data-has 22 | - katip 23 | - postgresql-simple 24 | - postgresql-simple-migration 25 | - resource-pool 26 | - hedis 27 | - amqp 28 | 29 | default-extensions: 30 | - NoImplicitPrelude 31 | - OverloadedStrings 32 | - QuasiQuotes 33 | - GeneralizedNewtypeDeriving 34 | - ConstraintKinds 35 | - FlexibleContexts 36 | - TemplateHaskell 37 | 38 | library: 39 | source-dirs: src 40 | executables: 41 | hauth-exe: 42 | main: Main.hs 43 | source-dirs: app 44 | ghc-options: 45 | - -threaded 46 | - -rtsopts 47 | - -with-rtsopts=-N 48 | dependencies: 49 | - hauth 50 | tests: 51 | hauth-test: 52 | main: Spec.hs 53 | source-dirs: test 54 | ghc-options: 55 | - -threaded 56 | - -rtsopts 57 | - -with-rtsopts=-N 58 | dependencies: 59 | - hauth 60 | -------------------------------------------------------------------------------- /06/src/Adapter/PostgreSQL/Migrations/00000_auths.sql: -------------------------------------------------------------------------------- 1 | create extension citext; 2 | create extension pgcrypto; 3 | 4 | create table auths ( 5 | id bigserial primary key not null, 6 | pass text not null, 7 | email citext not null unique, 8 | email_verification_code text not null, 9 | is_email_verified boolean not null 10 | ); -------------------------------------------------------------------------------- /06/src/Adapter/RabbitMQ/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.RabbitMQ.Auth where 2 | 3 | import ClassyPrelude 4 | import Adapter.RabbitMQ.Common 5 | import qualified Adapter.InMemory.Auth as M 6 | import Network.AMQP 7 | import Katip 8 | import Data.Aeson 9 | import Data.Aeson.TH 10 | import qualified Domain.Auth as D 11 | 12 | data EmailVerificationPayload = EmailVerificationPayload 13 | { emailVerificationPayloadEmail :: Text 14 | , emailVerificationPayloadVerificationCode :: Text 15 | } 16 | 17 | init :: (M.InMemory r m, KatipContext m, MonadCatch m) 18 | => State -> (m Bool -> IO Bool) -> IO () 19 | init state runner = do 20 | initQueue state "verifyEmail" "auth" "userRegistered" 21 | initConsumer state "verifyEmail" (consumeEmailVerification runner) 22 | 23 | consumeEmailVerification :: (M.InMemory r m, KatipContext m, MonadCatch m) 24 | => (m Bool -> IO Bool) -> Message -> IO Bool 25 | consumeEmailVerification runner msg = 26 | runner $ consumeAndProcess msg handler 27 | where 28 | handler payload = 29 | case D.mkEmail (emailVerificationPayloadEmail payload) of 30 | Left err -> withMsgAndErr msg err $ do 31 | $(logTM) ErrorS "Email format is invalid. Rejecting." 32 | return False 33 | Right email -> do 34 | let vCode = emailVerificationPayloadVerificationCode payload 35 | M.notifyEmailVerification email vCode 36 | return True 37 | 38 | notifyEmailVerification :: (Rabbit r m) => D.Email -> D.VerificationCode -> m () 39 | notifyEmailVerification email vCode = 40 | let payload = EmailVerificationPayload (D.rawEmail email) vCode 41 | in publish "auth" "userRegistered" payload 42 | 43 | -- JSON serde 44 | 45 | $(let structName = fromMaybe "" . lastMay . splitElem '.' . show $ ''EmailVerificationPayload 46 | lowercaseFirst (x:xs) = toLower [x] <> xs 47 | lowercaseFirst xs = xs 48 | options = defaultOptions 49 | { fieldLabelModifier = lowercaseFirst . drop (length structName) 50 | } 51 | in deriveJSON options ''EmailVerificationPayload) -------------------------------------------------------------------------------- /06/src/Adapter/Redis/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Redis.Auth where 2 | 3 | import ClassyPrelude 4 | import qualified Domain.Auth as D 5 | import Text.StringRandom 6 | import Data.Has 7 | import qualified Database.Redis as R 8 | 9 | type State = R.Connection 10 | 11 | type Redis r m = (Has State r, MonadReader r m, MonadIO m, MonadThrow m) 12 | 13 | -- | Create state from redis url string. 14 | -- format: redis://user:pass@host:port/db 15 | -- sample: redis://abc:def@localhost:6379/0 16 | withState :: String -> (State -> IO a) -> IO a 17 | withState connUrl action = 18 | case R.parseConnectInfo connUrl of 19 | Left _ -> 20 | throwString $ "Invalid Redis conn URL: " <> connUrl 21 | Right connInfo -> do 22 | conn <- R.checkedConnect connInfo 23 | action conn 24 | 25 | withConn :: Redis r m => R.Redis a -> m a 26 | withConn action = do 27 | conn <- asks getter 28 | liftIO $ R.runRedis conn action 29 | 30 | newSession :: Redis r m => D.UserId -> m D.SessionId 31 | newSession userId = do 32 | sId <- liftIO $ stringRandomIO "[a-zA-Z0-9]{32}" 33 | result <- withConn $ R.set (encodeUtf8 sId) (fromString . show $ userId) 34 | case result of 35 | Right R.Ok -> return sId 36 | err -> throwString $ "Unexpected redis error: " <> show err 37 | 38 | findUserIdBySessionId :: Redis r m => D.SessionId -> m (Maybe D.UserId) 39 | findUserIdBySessionId sId = do 40 | result <- withConn $ R.get (encodeUtf8 sId) 41 | return $ case result of 42 | Right (Just uIdStr) -> readMay . unpack . decodeUtf8 $ uIdStr 43 | err -> throwString $ "Unexpected redis error: " <> show err -------------------------------------------------------------------------------- /06/src/Domain/Validation.hs: -------------------------------------------------------------------------------- 1 | module Domain.Validation where 2 | 3 | import ClassyPrelude 4 | import Text.Regex.PCRE.Heavy 5 | 6 | type ErrMsg = Text 7 | type Validation a = a -> Maybe ErrMsg 8 | 9 | validate :: (a -> b) -> [Validation a] -> a -> Either [ErrMsg] b 10 | validate constructor validations val = 11 | case concatMap (\f -> maybeToList $ f val) validations of 12 | [] -> Right $ constructor val 13 | errs -> Left errs 14 | 15 | rangeBetween :: (Ord a) => a -> a -> ErrMsg -> Validation a 16 | rangeBetween minRange maxRange msg val = 17 | if val >= minRange && val <= maxRange then Nothing else Just msg 18 | 19 | lengthBetween :: (MonoFoldable a) => Int -> Int -> ErrMsg -> Validation a 20 | lengthBetween minLen maxLen msg val = 21 | rangeBetween minLen maxLen msg (length val) 22 | 23 | regexMatches :: Regex -> ErrMsg -> Validation Text 24 | regexMatches regex msg val = 25 | if val =~ regex then Nothing else Just msg 26 | -------------------------------------------------------------------------------- /06/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-10.3 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: 43 | - string-random-0.1.0.0 44 | - hedis-0.10.0 45 | 46 | # Override default flag values for local packages and extra-deps 47 | flags: {} 48 | 49 | # Extra package databases containing global packages 50 | extra-package-dbs: [] 51 | 52 | # Control whether we use the GHC we find on the path 53 | # system-ghc: true 54 | # 55 | # Require a specific version of stack, using version ranges 56 | # require-stack-version: -any # Default 57 | # require-stack-version: ">=1.5" 58 | # 59 | # Override the architecture used by stack, especially useful on Windows 60 | # arch: i386 61 | # arch: x86_64 62 | # 63 | # Extra directories used by stack for building 64 | # extra-include-dirs: [/path/to/dir] 65 | # extra-lib-dirs: [/path/to/dir] 66 | # 67 | # Allow a newer minor version of GHC than the snapshot specifies 68 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /06/test/Spec.hs: -------------------------------------------------------------------------------- 1 | import ClassyPrelude 2 | 3 | main :: IO () 4 | main = putStrLn "Test suite not yet implemented" 5 | -------------------------------------------------------------------------------- /07/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | .hspec-failures 3 | *.tix 4 | .DS_Store 5 | *.cabal 6 | -------------------------------------------------------------------------------- /07/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 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 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /07/README.md: -------------------------------------------------------------------------------- 1 | # hauth 2 | -------------------------------------------------------------------------------- /07/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /07/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ClassyPrelude 4 | import qualified Lib as Lib 5 | 6 | main :: IO () 7 | main = Lib.main 8 | -------------------------------------------------------------------------------- /07/package.yaml: -------------------------------------------------------------------------------- 1 | name: hauth 2 | version: '0.1.0.0' 3 | category: Web 4 | author: Ecky Putrady 5 | maintainer: eckyp@example.com 6 | copyright: 2017 Ecky Putrady 7 | license: BSD3 8 | github: githubuser/hauth 9 | extra-source-files: 10 | - README.md 11 | 12 | dependencies: 13 | - base 14 | - classy-prelude 15 | - pcre-heavy 16 | - time-lens 17 | - time 18 | - aeson 19 | - mtl 20 | - string-random 21 | - data-has 22 | - katip 23 | - postgresql-simple 24 | - postgresql-simple-migration 25 | - resource-pool 26 | - hedis 27 | - amqp 28 | - http-types 29 | - scotty 30 | - cookie 31 | - wai 32 | - wai-extra 33 | - blaze-builder 34 | - digestive-functors 35 | - digestive-functors-aeson 36 | 37 | default-extensions: 38 | - NoImplicitPrelude 39 | - OverloadedStrings 40 | - QuasiQuotes 41 | - GeneralizedNewtypeDeriving 42 | - ConstraintKinds 43 | - FlexibleContexts 44 | - TemplateHaskell 45 | 46 | library: 47 | source-dirs: src 48 | executables: 49 | hauth-exe: 50 | main: Main.hs 51 | source-dirs: app 52 | ghc-options: 53 | - -threaded 54 | - -rtsopts 55 | - -with-rtsopts=-N 56 | dependencies: 57 | - hauth 58 | tests: 59 | hauth-test: 60 | main: Spec.hs 61 | source-dirs: test 62 | ghc-options: 63 | - -threaded 64 | - -rtsopts 65 | - -with-rtsopts=-N 66 | dependencies: 67 | - hauth 68 | -------------------------------------------------------------------------------- /07/src/Adapter/HTTP/API/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Auth where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Domain.Auth 6 | import qualified Text.Digestive.Form as DF 7 | import Text.Digestive.Form ((.:)) 8 | import Adapter.HTTP.Common 9 | import Network.HTTP.Types.Status 10 | import Data.Aeson () 11 | import Katip 12 | 13 | -- * Routes 14 | 15 | routes :: ( ScottyError e, MonadIO m, KatipContext m, AuthRepo m 16 | , EmailVerificationNotif m, SessionRepo m) 17 | => ScottyT e m () 18 | routes = do 19 | -- register 20 | post "/api/auth/register" $ do 21 | input <- parseAndValidateJSON authForm 22 | domainResult <- lift $ register input 23 | case domainResult of 24 | Left RegistrationErrorEmailTaken -> do 25 | status status400 26 | json ("EmailTaken" :: Text) 27 | Right _ -> 28 | return () 29 | 30 | -- verify email 31 | post "/api/auth/verifyEmail" $ do 32 | input <- parseAndValidateJSON verifyEmailForm 33 | domainResult <- lift $ verifyEmail input 34 | case domainResult of 35 | Left EmailVerificationErrorInvalidCode -> do 36 | status status400 37 | json ("InvalidCode" :: Text) 38 | Right _ -> 39 | return () 40 | 41 | -- login 42 | post "/api/auth/login" $ do 43 | input <- parseAndValidateJSON authForm 44 | domainResult <- lift $ login input 45 | case domainResult of 46 | Left LoginErrorInvalidAuth -> do 47 | status status400 48 | json ("InvalidAuth" :: Text) 49 | Left LoginErrorEmailNotVerified -> do 50 | status status400 51 | json ("EmailNotVerified" :: Text) 52 | Right sId -> do 53 | setSessionIdInCookie sId 54 | return () 55 | 56 | -- get user 57 | get "/api/users" $ do 58 | userId <- reqCurrentUserId 59 | mayEmail <- lift $ getUser userId 60 | case mayEmail of 61 | Nothing -> 62 | raise $ stringError "Should not happen: SessionId map to invalid UserId" 63 | Just email -> 64 | json $ rawEmail email 65 | 66 | -- * Forms 67 | 68 | verifyEmailForm :: (Monad m) => DF.Form [Text] m VerificationCode 69 | verifyEmailForm = DF.text Nothing 70 | 71 | authForm :: (Monad m) => DF.Form [Text] m Auth 72 | authForm = 73 | Auth <$> "email" .: emailForm 74 | <*> "password" .: passwordForm 75 | where 76 | emailForm = DF.validate (toResult . mkEmail) (DF.text Nothing) 77 | passwordForm = DF.validate (toResult . mkPassword) (DF.text Nothing) -------------------------------------------------------------------------------- /07/src/Adapter/HTTP/Main.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Main where 2 | 3 | import Domain.Auth 4 | import ClassyPrelude 5 | import Web.Scotty.Trans 6 | import Network.HTTP.Types.Status 7 | import qualified Adapter.HTTP.API.Auth as AuthAPI 8 | import Adapter.HTTP.Common 9 | import Katip 10 | import Network.Wai 11 | import Network.Wai.Middleware.Gzip 12 | 13 | main :: ( MonadIO m, KatipContext m, AuthRepo m 14 | , EmailVerificationNotif m, SessionRepo m) 15 | => Int -> (m Response -> IO Response) -> IO () 16 | main port runner = 17 | scottyT port runner routes 18 | 19 | routes :: ( MonadIO m, KatipContext m, AuthRepo m 20 | , EmailVerificationNotif m, SessionRepo m) 21 | => ScottyT LText m () 22 | routes = do 23 | middleware $ gzip $ def { gzipFiles = GzipCompress } 24 | 25 | AuthAPI.routes 26 | 27 | defaultHandler $ \e -> do 28 | lift $ $(logTM) ErrorS $ "Unhandled error: " <> ls (showError e) 29 | status status500 30 | json ("InternalServerError" :: Text) 31 | -------------------------------------------------------------------------------- /07/src/Adapter/PostgreSQL/Migrations/00000_auths.sql: -------------------------------------------------------------------------------- 1 | create extension citext; 2 | create extension pgcrypto; 3 | 4 | create table auths ( 5 | id bigserial primary key not null, 6 | pass text not null, 7 | email citext not null unique, 8 | email_verification_code text not null, 9 | is_email_verified boolean not null 10 | ); -------------------------------------------------------------------------------- /07/src/Adapter/RabbitMQ/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.RabbitMQ.Auth where 2 | 3 | import ClassyPrelude 4 | import Adapter.RabbitMQ.Common 5 | import qualified Adapter.InMemory.Auth as M 6 | import Network.AMQP 7 | import Katip 8 | import Data.Aeson 9 | import Data.Aeson.TH 10 | import qualified Domain.Auth as D 11 | 12 | data EmailVerificationPayload = EmailVerificationPayload 13 | { emailVerificationPayloadEmail :: Text 14 | , emailVerificationPayloadVerificationCode :: Text 15 | } 16 | 17 | init :: (M.InMemory r m, KatipContext m, MonadCatch m) 18 | => State -> (m Bool -> IO Bool) -> IO () 19 | init state runner = do 20 | initQueue state "verifyEmail" "auth" "userRegistered" 21 | initConsumer state "verifyEmail" (consumeEmailVerification runner) 22 | 23 | consumeEmailVerification :: (M.InMemory r m, KatipContext m, MonadCatch m) 24 | => (m Bool -> IO Bool) -> Message -> IO Bool 25 | consumeEmailVerification runner msg = 26 | runner $ consumeAndProcess msg handler 27 | where 28 | handler payload = 29 | case D.mkEmail (emailVerificationPayloadEmail payload) of 30 | Left err -> withMsgAndErr msg err $ do 31 | $(logTM) ErrorS "Email format is invalid. Rejecting." 32 | return False 33 | Right email -> do 34 | let vCode = emailVerificationPayloadVerificationCode payload 35 | M.notifyEmailVerification email vCode 36 | return True 37 | 38 | notifyEmailVerification :: (Rabbit r m) => D.Email -> D.VerificationCode -> m () 39 | notifyEmailVerification email vCode = 40 | let payload = EmailVerificationPayload (D.rawEmail email) vCode 41 | in publish "auth" "userRegistered" payload 42 | 43 | -- JSON serde 44 | 45 | $(let structName = fromMaybe "" . lastMay . splitElem '.' . show $ ''EmailVerificationPayload 46 | lowercaseFirst (x:xs) = toLower [x] <> xs 47 | lowercaseFirst xs = xs 48 | options = defaultOptions 49 | { fieldLabelModifier = lowercaseFirst . drop (length structName) 50 | } 51 | in deriveJSON options ''EmailVerificationPayload) -------------------------------------------------------------------------------- /07/src/Adapter/Redis/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Redis.Auth where 2 | 3 | import ClassyPrelude 4 | import qualified Domain.Auth as D 5 | import Text.StringRandom 6 | import Data.Has 7 | import qualified Database.Redis as R 8 | 9 | type State = R.Connection 10 | 11 | type Redis r m = (Has State r, MonadReader r m, MonadIO m, MonadThrow m) 12 | 13 | -- | Create state from redis url string. 14 | -- format: redis://user:pass@host:port/db 15 | -- sample: redis://abc:def@localhost:6379/0 16 | withState :: String -> (State -> IO a) -> IO a 17 | withState connUrl action = 18 | case R.parseConnectInfo connUrl of 19 | Left _ -> 20 | throwString $ "Invalid Redis conn URL: " <> connUrl 21 | Right connInfo -> do 22 | conn <- R.checkedConnect connInfo 23 | action conn 24 | 25 | withConn :: Redis r m => R.Redis a -> m a 26 | withConn action = do 27 | conn <- asks getter 28 | liftIO $ R.runRedis conn action 29 | 30 | newSession :: Redis r m => D.UserId -> m D.SessionId 31 | newSession userId = do 32 | sId <- liftIO $ stringRandomIO "[a-zA-Z0-9]{32}" 33 | result <- withConn $ R.set (encodeUtf8 sId) (fromString . show $ userId) 34 | case result of 35 | Right R.Ok -> return sId 36 | err -> throwString $ "Unexpected redis error: " <> show err 37 | 38 | findUserIdBySessionId :: Redis r m => D.SessionId -> m (Maybe D.UserId) 39 | findUserIdBySessionId sId = do 40 | result <- withConn $ R.get (encodeUtf8 sId) 41 | return $ case result of 42 | Right (Just uIdStr) -> readMay . unpack . decodeUtf8 $ uIdStr 43 | err -> throwString $ "Unexpected redis error: " <> show err -------------------------------------------------------------------------------- /07/src/Domain/Validation.hs: -------------------------------------------------------------------------------- 1 | module Domain.Validation where 2 | 3 | import ClassyPrelude 4 | import Text.Regex.PCRE.Heavy 5 | 6 | type ErrMsg = Text 7 | type Validation a = a -> Maybe ErrMsg 8 | 9 | validate :: (a -> b) -> [Validation a] -> a -> Either [ErrMsg] b 10 | validate constructor validations val = 11 | case concatMap (\f -> maybeToList $ f val) validations of 12 | [] -> Right $ constructor val 13 | errs -> Left errs 14 | 15 | rangeBetween :: (Ord a) => a -> a -> ErrMsg -> Validation a 16 | rangeBetween minRange maxRange msg val = 17 | if val >= minRange && val <= maxRange then Nothing else Just msg 18 | 19 | lengthBetween :: (MonoFoldable a) => Int -> Int -> ErrMsg -> Validation a 20 | lengthBetween minLen maxLen msg val = 21 | rangeBetween minLen maxLen msg (length val) 22 | 23 | regexMatches :: Regex -> ErrMsg -> Validation Text 24 | regexMatches regex msg val = 25 | if val =~ regex then Nothing else Just msg 26 | -------------------------------------------------------------------------------- /07/test/Spec.hs: -------------------------------------------------------------------------------- 1 | import ClassyPrelude 2 | 3 | main :: IO () 4 | main = putStrLn "Test suite not yet implemented" 5 | -------------------------------------------------------------------------------- /08/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | .hspec-failures 3 | *.tix 4 | .DS_Store 5 | *.cabal 6 | -------------------------------------------------------------------------------- /08/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 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 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /08/README.md: -------------------------------------------------------------------------------- 1 | # hauth 2 | -------------------------------------------------------------------------------- /08/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /08/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ClassyPrelude 4 | import qualified Lib as Lib 5 | 6 | main :: IO () 7 | main = Lib.main 8 | -------------------------------------------------------------------------------- /08/package.yaml: -------------------------------------------------------------------------------- 1 | name: hauth 2 | version: '0.1.0.0' 3 | category: Web 4 | author: Ecky Putrady 5 | maintainer: eckyp@example.com 6 | copyright: 2017 Ecky Putrady 7 | license: BSD3 8 | github: githubuser/hauth 9 | extra-source-files: 10 | - README.md 11 | 12 | dependencies: 13 | - base 14 | - classy-prelude 15 | - pcre-heavy 16 | - time-lens 17 | - time 18 | - aeson 19 | - mtl 20 | - string-random 21 | - data-has 22 | - katip 23 | - postgresql-simple 24 | - postgresql-simple-migration 25 | - resource-pool 26 | - hedis 27 | - amqp 28 | - http-types 29 | - scotty 30 | - cookie 31 | - wai 32 | - wai-extra 33 | - blaze-builder 34 | - digestive-functors 35 | - digestive-functors-aeson 36 | - blaze-html 37 | - digestive-functors-blaze 38 | - digestive-functors-scotty 39 | - wai-middleware-static 40 | - warp 41 | 42 | default-extensions: 43 | - NoImplicitPrelude 44 | - OverloadedStrings 45 | - QuasiQuotes 46 | - GeneralizedNewtypeDeriving 47 | - ConstraintKinds 48 | - FlexibleContexts 49 | - TemplateHaskell 50 | 51 | library: 52 | source-dirs: src 53 | executables: 54 | hauth-exe: 55 | main: Main.hs 56 | source-dirs: app 57 | ghc-options: 58 | - -threaded 59 | - -rtsopts 60 | - -with-rtsopts=-N 61 | dependencies: 62 | - hauth 63 | tests: 64 | hauth-test: 65 | main: Spec.hs 66 | source-dirs: test 67 | ghc-options: 68 | - -threaded 69 | - -rtsopts 70 | - -with-rtsopts=-N 71 | dependencies: 72 | - hauth 73 | -------------------------------------------------------------------------------- /08/src/Adapter/HTTP/API/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Common where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Domain.Auth 6 | import qualified Text.Digestive.Form as DF 7 | import qualified Text.Digestive.Aeson as DF 8 | import Data.Aeson hiding (json) 9 | import Network.HTTP.Types.Status 10 | import Adapter.HTTP.Common 11 | 12 | -- * Forms 13 | 14 | parseAndValidateJSON :: (ScottyError e, MonadIO m, ToJSON v) 15 | => DF.Form v m a -> ActionT e m a 16 | parseAndValidateJSON form = do 17 | val <- jsonData `rescue` (\_ -> return Null) 18 | validationResult <- lift $ DF.digestJSON form val 19 | case validationResult of 20 | (v, Nothing) -> do 21 | status status400 22 | json $ DF.jsonErrors v 23 | finish 24 | (_, Just result) -> 25 | return result 26 | 27 | -- * Sessions 28 | 29 | reqCurrentUserId :: (SessionRepo m, ScottyError e) => ActionT e m UserId 30 | reqCurrentUserId = do 31 | mayUserId <- getCurrentUserId 32 | case mayUserId of 33 | Nothing -> do 34 | status status401 35 | json ("AuthRequired" :: Text) 36 | finish 37 | Just userId -> 38 | return userId -------------------------------------------------------------------------------- /08/src/Adapter/HTTP/API/Main.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Main where 2 | 3 | import Domain.Auth 4 | import ClassyPrelude 5 | import Web.Scotty.Trans 6 | import Network.HTTP.Types.Status 7 | import qualified Adapter.HTTP.API.Auth as Auth 8 | import Adapter.HTTP.API.Common 9 | import Katip 10 | import Network.Wai 11 | import Network.Wai.Middleware.Gzip 12 | 13 | main :: ( MonadIO m, KatipContext m, AuthRepo m 14 | , EmailVerificationNotif m, SessionRepo m) 15 | => (m Response -> IO Response) -> IO Application 16 | main runner = 17 | scottyAppT runner routes 18 | 19 | routes :: ( MonadIO m, KatipContext m, AuthRepo m 20 | , EmailVerificationNotif m, SessionRepo m) 21 | => ScottyT LText m () 22 | routes = do 23 | middleware $ gzip $ def { gzipFiles = GzipCompress } 24 | 25 | Auth.routes 26 | 27 | notFound $ do 28 | status status404 29 | json ("NotFound" :: Text) 30 | 31 | defaultHandler $ \e -> do 32 | lift $ $(logTM) ErrorS $ "Unhandled error: " <> ls (showError e) 33 | status status500 34 | json ("InternalServerError" :: Text) 35 | -------------------------------------------------------------------------------- /08/src/Adapter/HTTP/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Common where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Blaze.ByteString.Builder (toLazyByteString) 6 | import Web.Cookie 7 | import Domain.Auth 8 | import Data.Time.Lens 9 | import qualified Text.Digestive.Types as DF 10 | 11 | -- * Forms 12 | 13 | toResult :: Either e a -> DF.Result e a 14 | toResult = either DF.Error DF.Success 15 | 16 | -- * Cookies 17 | 18 | setCookie :: (ScottyError e, Monad m) => SetCookie -> ActionT e m () 19 | setCookie = setHeader "Set-Cookie" . decodeUtf8 . toLazyByteString . renderSetCookie 20 | 21 | getCookie :: (ScottyError e, Monad m) => Text -> ActionT e m (Maybe Text) 22 | getCookie key = do 23 | mCookieStr <- header "Cookie" 24 | return $ do 25 | cookie <- parseCookies . encodeUtf8 . toStrict <$> mCookieStr 26 | let bsKey = encodeUtf8 key 27 | val <- lookup bsKey cookie 28 | return $ decodeUtf8 val 29 | 30 | -- * Sessions 31 | 32 | setSessionIdInCookie :: (MonadIO m, ScottyError e) => SessionId -> ActionT e m () 33 | setSessionIdInCookie sId = do 34 | curTime <- liftIO getCurrentTime 35 | setCookie $ def { setCookieName = "sId" 36 | , setCookiePath = Just "/" 37 | , setCookieValue = encodeUtf8 sId 38 | , setCookieExpires = Just $ modL month (+ 1) curTime 39 | , setCookieHttpOnly = True 40 | , setCookieSecure = False 41 | , setCookieSameSite = Just sameSiteLax 42 | } 43 | 44 | getCurrentUserId :: (SessionRepo m, ScottyError e) => ActionT e m (Maybe UserId) 45 | getCurrentUserId = do 46 | maySessionId <- getCookie "sId" 47 | case maySessionId of 48 | Nothing -> return Nothing 49 | Just sId -> lift $ resolveSessionId sId -------------------------------------------------------------------------------- /08/src/Adapter/HTTP/Main.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Main where 2 | 3 | import Domain.Auth 4 | import ClassyPrelude 5 | import qualified Adapter.HTTP.API.Main as API 6 | import qualified Adapter.HTTP.Web.Main as Web 7 | import Katip 8 | import Network.Wai 9 | import Network.Wai.Handler.Warp 10 | import Network.Wai.Middleware.Vhost 11 | 12 | main :: ( MonadIO m, KatipContext m, AuthRepo m 13 | , EmailVerificationNotif m, SessionRepo m) 14 | => Int -> (m Response -> IO Response) -> IO () 15 | main port runner = do 16 | web <- Web.main runner 17 | api <- API.main runner 18 | run port $ vhost [(pathBeginsWith "api", api)] web 19 | where 20 | pathBeginsWith path req = headMay (pathInfo req) == Just path 21 | -------------------------------------------------------------------------------- /08/src/Adapter/HTTP/Web/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Web.Common where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Domain.Auth 6 | import qualified Text.Digestive.View as DF 7 | import Text.Blaze.Html5 ((!)) 8 | import qualified Text.Blaze.Html5 as H 9 | import qualified Text.Blaze.Html5.Attributes as A 10 | import qualified Text.Blaze.Html.Renderer.Text as H 11 | import Adapter.HTTP.Common 12 | 13 | -- * Views 14 | 15 | renderHtml :: (ScottyError e, Monad m) => H.Html -> ActionT e m () 16 | renderHtml = html . H.renderHtml 17 | 18 | mainLayout :: Text -> H.Html -> H.Html 19 | mainLayout title content = 20 | H.docTypeHtml $ do 21 | H.head $ do 22 | favicon "/images/logo.png" 23 | H.title $ H.toHtml title 24 | H.body $ do 25 | H.div $ H.img ! A.src "/images/logo.png" 26 | H.div content 27 | where 28 | favicon path = 29 | H.link ! A.rel "icon" 30 | ! A.type_ "image/png" 31 | ! A.href path 32 | 33 | formLayout :: DF.View a -> Text -> H.Html -> H.Html 34 | formLayout view action = 35 | H.form ! A.method "POST" 36 | ! A.enctype (H.toValue $ show $ DF.viewEncType view) 37 | ! A.action (H.toValue action) 38 | 39 | -- * Sessions 40 | 41 | reqCurrentUserId :: (SessionRepo m, ScottyError e) => ActionT e m UserId 42 | reqCurrentUserId = do 43 | mUserId <- getCurrentUserId 44 | case mUserId of 45 | Nothing -> 46 | redirect "/auth/login" 47 | Just userId -> 48 | return userId -------------------------------------------------------------------------------- /08/src/Adapter/HTTP/Web/Main.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Web.Main where 2 | 3 | import Domain.Auth 4 | import ClassyPrelude 5 | import Web.Scotty.Trans 6 | import Network.HTTP.Types.Status 7 | import qualified Adapter.HTTP.Web.Auth as Auth 8 | import Katip 9 | import Network.Wai 10 | import Network.Wai.Middleware.Static 11 | import Network.Wai.Middleware.Gzip 12 | 13 | main :: ( MonadIO m, KatipContext m, AuthRepo m 14 | , EmailVerificationNotif m, SessionRepo m) 15 | => (m Response -> IO Response) -> IO Application 16 | main runner = do 17 | cacheContainer <- initCaching PublicStaticCaching 18 | scottyAppT runner $ routes cacheContainer 19 | 20 | routes :: ( MonadIO m, KatipContext m, AuthRepo m 21 | , EmailVerificationNotif m, SessionRepo m) 22 | => CacheContainer -> ScottyT LText m () 23 | routes cacheContainer = do 24 | middleware $ 25 | gzip $ def { gzipFiles = GzipCompress } 26 | middleware $ 27 | staticPolicy' cacheContainer (addBase "src/Adapter/HTTP/Web/static") 28 | 29 | Auth.routes 30 | 31 | notFound $ do 32 | status status404 33 | text "Not found" 34 | 35 | defaultHandler $ \e -> do 36 | lift $ $(logTM) ErrorS $ "Unhandled error: " <> ls (showError e) 37 | status status500 38 | text "Internal server error!" 39 | -------------------------------------------------------------------------------- /08/src/Adapter/HTTP/Web/static/images/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-webdev-haskell/17b90c06030def254bb0497b9e357f5d3b96d0cf/08/src/Adapter/HTTP/Web/static/images/logo.png -------------------------------------------------------------------------------- /08/src/Adapter/PostgreSQL/Migrations/00000_auths.sql: -------------------------------------------------------------------------------- 1 | create extension citext; 2 | create extension pgcrypto; 3 | 4 | create table auths ( 5 | id bigserial primary key not null, 6 | pass text not null, 7 | email citext not null unique, 8 | email_verification_code text not null, 9 | is_email_verified boolean not null 10 | ); -------------------------------------------------------------------------------- /08/src/Adapter/RabbitMQ/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.RabbitMQ.Auth where 2 | 3 | import ClassyPrelude 4 | import Adapter.RabbitMQ.Common 5 | import qualified Adapter.InMemory.Auth as M 6 | import Network.AMQP 7 | import Katip 8 | import Data.Aeson 9 | import Data.Aeson.TH 10 | import qualified Domain.Auth as D 11 | 12 | data EmailVerificationPayload = EmailVerificationPayload 13 | { emailVerificationPayloadEmail :: Text 14 | , emailVerificationPayloadVerificationCode :: Text 15 | } 16 | 17 | init :: (M.InMemory r m, KatipContext m, MonadCatch m) 18 | => State -> (m Bool -> IO Bool) -> IO () 19 | init state runner = do 20 | initQueue state "verifyEmail" "auth" "userRegistered" 21 | initConsumer state "verifyEmail" (consumeEmailVerification runner) 22 | 23 | consumeEmailVerification :: (M.InMemory r m, KatipContext m, MonadCatch m) 24 | => (m Bool -> IO Bool) -> Message -> IO Bool 25 | consumeEmailVerification runner msg = 26 | runner $ consumeAndProcess msg handler 27 | where 28 | handler payload = 29 | case D.mkEmail (emailVerificationPayloadEmail payload) of 30 | Left err -> withMsgAndErr msg err $ do 31 | $(logTM) ErrorS "Email format is invalid. Rejecting." 32 | return False 33 | Right email -> do 34 | let vCode = emailVerificationPayloadVerificationCode payload 35 | M.notifyEmailVerification email vCode 36 | return True 37 | 38 | notifyEmailVerification :: (Rabbit r m) => D.Email -> D.VerificationCode -> m () 39 | notifyEmailVerification email vCode = 40 | let payload = EmailVerificationPayload (D.rawEmail email) vCode 41 | in publish "auth" "userRegistered" payload 42 | 43 | -- JSON serde 44 | 45 | $(let structName = fromMaybe "" . lastMay . splitElem '.' . show $ ''EmailVerificationPayload 46 | lowercaseFirst (x:xs) = toLower [x] <> xs 47 | lowercaseFirst xs = xs 48 | options = defaultOptions 49 | { fieldLabelModifier = lowercaseFirst . drop (length structName) 50 | } 51 | in deriveJSON options ''EmailVerificationPayload) -------------------------------------------------------------------------------- /08/src/Adapter/Redis/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Redis.Auth where 2 | 3 | import ClassyPrelude 4 | import qualified Domain.Auth as D 5 | import Text.StringRandom 6 | import Data.Has 7 | import qualified Database.Redis as R 8 | 9 | type State = R.Connection 10 | 11 | type Redis r m = (Has State r, MonadReader r m, MonadIO m, MonadThrow m) 12 | 13 | -- | Create state from redis url string. 14 | -- format: redis://user:pass@host:port/db 15 | -- sample: redis://abc:def@localhost:6379/0 16 | withState :: String -> (State -> IO a) -> IO a 17 | withState connUrl action = 18 | case R.parseConnectInfo connUrl of 19 | Left _ -> 20 | throwString $ "Invalid Redis conn URL: " <> connUrl 21 | Right connInfo -> do 22 | conn <- R.checkedConnect connInfo 23 | action conn 24 | 25 | withConn :: Redis r m => R.Redis a -> m a 26 | withConn action = do 27 | conn <- asks getter 28 | liftIO $ R.runRedis conn action 29 | 30 | newSession :: Redis r m => D.UserId -> m D.SessionId 31 | newSession userId = do 32 | sId <- liftIO $ stringRandomIO "[a-zA-Z0-9]{32}" 33 | result <- withConn $ R.set (encodeUtf8 sId) (fromString . show $ userId) 34 | case result of 35 | Right R.Ok -> return sId 36 | err -> throwString $ "Unexpected redis error: " <> show err 37 | 38 | findUserIdBySessionId :: Redis r m => D.SessionId -> m (Maybe D.UserId) 39 | findUserIdBySessionId sId = do 40 | result <- withConn $ R.get (encodeUtf8 sId) 41 | return $ case result of 42 | Right (Just uIdStr) -> readMay . unpack . decodeUtf8 $ uIdStr 43 | err -> throwString $ "Unexpected redis error: " <> show err -------------------------------------------------------------------------------- /08/src/Domain/Validation.hs: -------------------------------------------------------------------------------- 1 | module Domain.Validation where 2 | 3 | import ClassyPrelude 4 | import Text.Regex.PCRE.Heavy 5 | 6 | type ErrMsg = Text 7 | type Validation a = a -> Maybe ErrMsg 8 | 9 | validate :: (a -> b) -> [Validation a] -> a -> Either [ErrMsg] b 10 | validate constructor validations val = 11 | case concatMap (\f -> maybeToList $ f val) validations of 12 | [] -> Right $ constructor val 13 | errs -> Left errs 14 | 15 | rangeBetween :: (Ord a) => a -> a -> ErrMsg -> Validation a 16 | rangeBetween minRange maxRange msg val = 17 | if val >= minRange && val <= maxRange then Nothing else Just msg 18 | 19 | lengthBetween :: (MonoFoldable a) => Int -> Int -> ErrMsg -> Validation a 20 | lengthBetween minLen maxLen msg val = 21 | rangeBetween minLen maxLen msg (length val) 22 | 23 | regexMatches :: Regex -> ErrMsg -> Validation Text 24 | regexMatches regex msg val = 25 | if val =~ regex then Nothing else Just msg 26 | -------------------------------------------------------------------------------- /08/test/Spec.hs: -------------------------------------------------------------------------------- 1 | import ClassyPrelude 2 | 3 | main :: IO () 4 | main = putStrLn "Test suite not yet implemented" 5 | -------------------------------------------------------------------------------- /09/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | .hspec-failures 3 | *.tix 4 | .DS_Store 5 | *.cabal 6 | -------------------------------------------------------------------------------- /09/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 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 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /09/README.md: -------------------------------------------------------------------------------- 1 | # hauth 2 | -------------------------------------------------------------------------------- /09/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /09/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ClassyPrelude 4 | import qualified Lib as Lib 5 | 6 | main :: IO () 7 | main = Lib.main 8 | -------------------------------------------------------------------------------- /09/package.yaml: -------------------------------------------------------------------------------- 1 | name: hauth 2 | version: '0.1.0.0' 3 | category: Web 4 | author: Ecky Putrady 5 | maintainer: eckyp@example.com 6 | copyright: 2017 Ecky Putrady 7 | license: BSD3 8 | github: githubuser/hauth 9 | extra-source-files: 10 | - README.md 11 | 12 | dependencies: 13 | - base 14 | - classy-prelude 15 | - pcre-heavy 16 | - time-lens 17 | - time 18 | - aeson 19 | - mtl 20 | - string-random 21 | - data-has 22 | - katip 23 | - postgresql-simple 24 | - postgresql-simple-migration 25 | - resource-pool 26 | - hedis 27 | - amqp 28 | - http-types 29 | - scotty 30 | - cookie 31 | - wai 32 | - wai-extra 33 | - blaze-builder 34 | - digestive-functors 35 | - digestive-functors-aeson 36 | - blaze-html 37 | - digestive-functors-blaze 38 | - digestive-functors-scotty 39 | - wai-middleware-static 40 | - warp 41 | - http-client 42 | - http-client-tls 43 | - template-haskell 44 | 45 | default-extensions: 46 | - NoImplicitPrelude 47 | - OverloadedStrings 48 | - QuasiQuotes 49 | - GeneralizedNewtypeDeriving 50 | - ConstraintKinds 51 | - FlexibleContexts 52 | - TemplateHaskell 53 | 54 | library: 55 | source-dirs: src 56 | dependencies: 57 | executables: 58 | hauth-exe: 59 | main: Main.hs 60 | source-dirs: app 61 | ghc-options: 62 | - -threaded 63 | - -rtsopts 64 | - -with-rtsopts=-N 65 | dependencies: 66 | - hauth 67 | tests: 68 | hauth-test: 69 | main: Spec.hs 70 | source-dirs: test 71 | ghc-options: 72 | - -threaded 73 | - -rtsopts 74 | - -with-rtsopts=-N 75 | dependencies: 76 | - hauth 77 | -------------------------------------------------------------------------------- /09/src/Adapter/HTTP/API/Client/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Client.Auth where 2 | 3 | import ClassyPrelude 4 | import Network.HTTP.Client 5 | import Data.Has 6 | import qualified Domain.Auth as D 7 | import Network.HTTP.Types 8 | import Adapter.HTTP.API.Types.Auth () 9 | import Adapter.HTTP.API.Client.Common 10 | import Data.Aeson 11 | 12 | register :: HttpClient r m => D.Auth -> m (Either D.RegistrationError ()) 13 | register auth = do 14 | State initReq mgr <- asks getter 15 | let req = initReq 16 | { method = "POST" 17 | , path = "/api/auth/register" 18 | , requestBody = RequestBodyLBS $ encode auth 19 | } 20 | resp <- liftIO $ httpLbs req mgr 21 | case responseStatus resp of 22 | (Status 200 _) -> 23 | return $ Right () 24 | _ -> 25 | Left <$> parseOrErr req resp 26 | 27 | verifyEmail :: HttpClient r m 28 | => D.VerificationCode -> m (Either D.EmailVerificationError ()) 29 | verifyEmail code = do 30 | State initReq mgr <- asks getter 31 | let req = initReq 32 | { method = "POST" 33 | , path = "/api/auth/verifyEmail" 34 | , requestBody = RequestBodyLBS . encode $ code 35 | } 36 | resp <- liftIO $ httpLbs req mgr 37 | case responseStatus resp of 38 | (Status 200 _) -> 39 | return $ Right () 40 | _ -> 41 | Left <$> parseOrErr req resp 42 | 43 | login :: HttpClient r m => D.Auth -> m (Either D.LoginError Session) 44 | login auth = do 45 | State initReq mgr <- asks getter 46 | let req = initReq 47 | { method = "POST" 48 | , path = "/api/auth/login" 49 | , requestBody = RequestBodyLBS $ encode auth 50 | } 51 | resp <- liftIO $ httpLbs req mgr 52 | case responseStatus resp of 53 | (Status 200 _) -> 54 | return $ Right $ responseCookieJar resp 55 | _ -> 56 | Left <$> parseOrErr req resp 57 | 58 | getUser :: HttpClient r m => Session -> m D.Email 59 | getUser session = do 60 | State initReq mgr <- asks getter 61 | let req = initReq 62 | { method = "GET" 63 | , path = "/api/users" 64 | , cookieJar = Just session 65 | } 66 | resp <- liftIO $ httpLbs req mgr 67 | case responseStatus resp of 68 | (Status 200 _) -> 69 | parseOrErr req resp 70 | _ -> 71 | throw $ UnexpectedResponse req resp -------------------------------------------------------------------------------- /09/src/Adapter/HTTP/API/Client/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Client.Common where 2 | 3 | import ClassyPrelude 4 | import Network.HTTP.Client 5 | import Network.HTTP.Client.TLS 6 | import Data.Has 7 | import Data.Aeson 8 | 9 | newtype Config = Config 10 | { configUrl :: String 11 | } 12 | 13 | data State = State 14 | { stateInitReq :: Request 15 | , stateManager :: Manager 16 | } 17 | 18 | type HttpClient r m = (MonadReader r m, Has State r, MonadIO m, MonadThrow m) 19 | 20 | type Session = CookieJar 21 | 22 | data UnexpectedResponse a = 23 | UnexpectedResponse Request (Response a) deriving (Show) 24 | 25 | instance (Typeable a, Show a) => Exception (UnexpectedResponse a) 26 | 27 | -- * Initialize 28 | 29 | withState :: Config -> (State -> IO a) -> IO a 30 | withState cfg action = do 31 | mgr <- newManager tlsManagerSettings 32 | initReq <- parseRequest $ configUrl cfg 33 | let initReqWithJson = 34 | initReq { requestHeaders = 35 | [("Content-Type", "application/json; charset=utf-8")] 36 | } 37 | action $ State initReqWithJson mgr 38 | 39 | -- * Helpers 40 | 41 | parseOrErr :: (MonadThrow m, FromJSON a) 42 | => Request -> Response LByteString -> m a 43 | parseOrErr req resp = 44 | case eitherDecode' $ responseBody resp of 45 | Left _ -> throw $ UnexpectedResponse req resp 46 | Right a -> return a -------------------------------------------------------------------------------- /09/src/Adapter/HTTP/API/Server/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Server.Auth where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Domain.Auth 6 | import qualified Text.Digestive.Form as DF 7 | import Text.Digestive.Form ((.:)) 8 | import Adapter.HTTP.Common 9 | import Adapter.HTTP.API.Server.Common 10 | import Adapter.HTTP.API.Types.Auth () 11 | import Network.HTTP.Types.Status 12 | import Katip 13 | 14 | -- * Routes 15 | 16 | routes :: ( ScottyError e, MonadIO m, KatipContext m, AuthRepo m 17 | , EmailVerificationNotif m, SessionRepo m) 18 | => ScottyT e m () 19 | routes = do 20 | -- register 21 | post "/api/auth/register" $ do 22 | input <- parseAndValidateJSON authForm 23 | domainResult <- lift $ register input 24 | case domainResult of 25 | Left err -> do 26 | status status400 27 | json err 28 | Right _ -> 29 | return () 30 | 31 | -- verify email 32 | post "/api/auth/verifyEmail" $ do 33 | input <- parseAndValidateJSON verifyEmailForm 34 | domainResult <- lift $ verifyEmail input 35 | case domainResult of 36 | Left err -> do 37 | status status400 38 | json err 39 | Right _ -> 40 | return () 41 | 42 | -- login 43 | post "/api/auth/login" $ do 44 | input <- parseAndValidateJSON authForm 45 | domainResult <- lift $ login input 46 | case domainResult of 47 | Left err -> do 48 | status status400 49 | json err 50 | Right sId -> do 51 | setSessionIdInCookie sId 52 | return () 53 | 54 | -- get user 55 | get "/api/users" $ do 56 | userId <- reqCurrentUserId 57 | mayEmail <- lift $ getUser userId 58 | case mayEmail of 59 | Nothing -> 60 | raise $ stringError "Should not happen: SessionId map to invalid UserId" 61 | Just email -> 62 | json email 63 | 64 | -- * Forms 65 | 66 | verifyEmailForm :: (Monad m) => DF.Form [Text] m VerificationCode 67 | verifyEmailForm = DF.text Nothing 68 | 69 | authForm :: (Monad m) => DF.Form [Text] m Auth 70 | authForm = 71 | Auth <$> "email" .: emailForm 72 | <*> "password" .: passwordForm 73 | where 74 | emailForm = DF.validate (toResult . mkEmail) (DF.text Nothing) 75 | passwordForm = DF.validate (toResult . mkPassword) (DF.text Nothing) -------------------------------------------------------------------------------- /09/src/Adapter/HTTP/API/Server/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Server.Common where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Domain.Auth 6 | import qualified Text.Digestive.Form as DF 7 | import qualified Text.Digestive.Aeson as DF 8 | import Data.Aeson hiding (json) 9 | import Network.HTTP.Types.Status 10 | import Adapter.HTTP.Common 11 | 12 | -- * Forms 13 | 14 | parseAndValidateJSON :: (ScottyError e, MonadIO m, ToJSON v) 15 | => DF.Form v m a -> ActionT e m a 16 | parseAndValidateJSON form = do 17 | val <- jsonData `rescue` (\_ -> return Null) 18 | validationResult <- lift $ DF.digestJSON form val 19 | case validationResult of 20 | (v, Nothing) -> do 21 | status status400 22 | json $ DF.jsonErrors v 23 | finish 24 | (_, Just result) -> 25 | return result 26 | 27 | -- * Sessions 28 | 29 | reqCurrentUserId :: (SessionRepo m, ScottyError e) => ActionT e m UserId 30 | reqCurrentUserId = do 31 | mayUserId <- getCurrentUserId 32 | case mayUserId of 33 | Nothing -> do 34 | status status401 35 | json ("AuthRequired" :: Text) 36 | finish 37 | Just userId -> 38 | return userId -------------------------------------------------------------------------------- /09/src/Adapter/HTTP/API/Server/Main.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Server.Main where 2 | 3 | import Domain.Auth 4 | import ClassyPrelude 5 | import Web.Scotty.Trans 6 | import Network.HTTP.Types.Status 7 | import qualified Adapter.HTTP.API.Server.Auth as Auth 8 | import Adapter.HTTP.API.Server.Common 9 | import Katip 10 | import Network.Wai 11 | import Network.Wai.Middleware.Gzip 12 | 13 | main :: ( MonadIO m, KatipContext m, AuthRepo m 14 | , EmailVerificationNotif m, SessionRepo m) 15 | => (m Response -> IO Response) -> IO Application 16 | main runner = 17 | scottyAppT runner routes 18 | 19 | routes :: ( MonadIO m, KatipContext m, AuthRepo m 20 | , EmailVerificationNotif m, SessionRepo m) 21 | => ScottyT LText m () 22 | routes = do 23 | middleware $ gzip $ def { gzipFiles = GzipCompress } 24 | 25 | Auth.routes 26 | 27 | notFound $ do 28 | status status404 29 | json ("NotFound" :: Text) 30 | 31 | defaultHandler $ \e -> do 32 | lift $ $(logTM) ErrorS $ "Unhandled error: " <> ls (showError e) 33 | status status500 34 | json ("InternalServerError" :: Text) 35 | -------------------------------------------------------------------------------- /09/src/Adapter/HTTP/API/Types/AesonHelper.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Types.AesonHelper where 2 | 3 | import ClassyPrelude 4 | import Data.Aeson.TH 5 | import Data.Aeson.Types 6 | import Language.Haskell.TH.Syntax 7 | 8 | withSmartConstructor :: (a -> Either [Text] b) -> a -> Parser b 9 | withSmartConstructor constructor a = 10 | case constructor a of 11 | Left errs -> fail $ intercalate ". " . map unpack $ errs 12 | Right val -> return val 13 | 14 | deriveJSONRecord :: Name -> Q [Dec] 15 | deriveJSONRecord record = 16 | let lowerCaseFirst (y:ys) = toLower [y] <> ys 17 | lowerCaseFirst "" = "" 18 | structName = fromMaybe "" . lastMay . splitElem '.' . show $ record 19 | opts = defaultOptions 20 | { fieldLabelModifier = lowerCaseFirst . drop (length structName) 21 | } 22 | in deriveJSON opts record 23 | 24 | deriveJSONSumType :: Name -> Q [Dec] 25 | deriveJSONSumType record = 26 | let structName = fromMaybe "" . lastMay . splitElem '.' . show $ record 27 | opts = defaultOptions 28 | { constructorTagModifier = drop (length structName) 29 | , tagSingleConstructors = True 30 | } 31 | in deriveJSON opts record 32 | 33 | deriveToJSONUnwrap :: Name -> Q [Dec] 34 | deriveToJSONUnwrap = 35 | let opts = defaultOptions { unwrapUnaryRecords = True } 36 | in deriveToJSON opts -------------------------------------------------------------------------------- /09/src/Adapter/HTTP/API/Types/Auth.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Adapter.HTTP.API.Types.Auth where 4 | 5 | import ClassyPrelude 6 | import Domain.Auth 7 | import Data.Aeson 8 | import Adapter.HTTP.API.Types.AesonHelper 9 | 10 | instance FromJSON Email where 11 | parseJSON = 12 | withText "Email" $ withSmartConstructor mkEmail 13 | 14 | instance FromJSON Password where 15 | parseJSON = 16 | withText "Password" $ withSmartConstructor mkPassword 17 | 18 | $(map concat . sequence $ 19 | [ deriveJSONRecord ''Auth 20 | , deriveToJSONUnwrap ''Email 21 | , deriveToJSONUnwrap ''Password 22 | , deriveJSONSumType ''RegistrationError 23 | , deriveJSONSumType ''EmailVerificationError 24 | , deriveJSONSumType ''LoginError 25 | ]) -------------------------------------------------------------------------------- /09/src/Adapter/HTTP/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Common where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Blaze.ByteString.Builder (toLazyByteString) 6 | import Web.Cookie 7 | import Domain.Auth 8 | import Data.Time.Lens 9 | import qualified Text.Digestive.Types as DF 10 | 11 | -- * Forms 12 | 13 | toResult :: Either e a -> DF.Result e a 14 | toResult = either DF.Error DF.Success 15 | 16 | -- * Cookies 17 | 18 | setCookie :: (ScottyError e, Monad m) => SetCookie -> ActionT e m () 19 | setCookie = setHeader "Set-Cookie" . decodeUtf8 . toLazyByteString . renderSetCookie 20 | 21 | getCookie :: (ScottyError e, Monad m) => Text -> ActionT e m (Maybe Text) 22 | getCookie key = do 23 | mCookieStr <- header "Cookie" 24 | return $ do 25 | cookie <- parseCookies . encodeUtf8 . toStrict <$> mCookieStr 26 | let bsKey = encodeUtf8 key 27 | (_, val) <- find ((== bsKey) . fst) cookie 28 | return $ decodeUtf8 val 29 | 30 | -- * Sessions 31 | 32 | setSessionIdInCookie :: (MonadIO m, ScottyError e) => SessionId -> ActionT e m () 33 | setSessionIdInCookie sId = do 34 | curTime <- liftIO getCurrentTime 35 | setCookie $ def { setCookieName = "sId" 36 | , setCookiePath = Just "/" 37 | , setCookieValue = encodeUtf8 sId 38 | , setCookieExpires = Just $ modL month (+ 1) curTime 39 | , setCookieHttpOnly = True 40 | , setCookieSecure = False 41 | , setCookieSameSite = Just sameSiteLax 42 | } 43 | 44 | getCurrentUserId :: (SessionRepo m, ScottyError e) => ActionT e m (Maybe UserId) 45 | getCurrentUserId = do 46 | maySessionId <- getCookie "sId" 47 | case maySessionId of 48 | Nothing -> return Nothing 49 | Just sId -> lift $ resolveSessionId sId -------------------------------------------------------------------------------- /09/src/Adapter/HTTP/Main.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Main where 2 | 3 | import Domain.Auth 4 | import ClassyPrelude 5 | import qualified Adapter.HTTP.API.Server.Main as API 6 | import qualified Adapter.HTTP.Web.Main as Web 7 | import Katip 8 | import Network.Wai 9 | import Network.Wai.Handler.Warp 10 | import Network.Wai.Middleware.Vhost 11 | 12 | main :: ( MonadIO m, KatipContext m, AuthRepo m 13 | , EmailVerificationNotif m, SessionRepo m) 14 | => Int -> (m Response -> IO Response) -> IO () 15 | main port runner = do 16 | web <- Web.main runner 17 | api <- API.main runner 18 | run port $ vhost [(pathBeginsWith "api", api)] web 19 | where 20 | pathBeginsWith path req = headMay (pathInfo req) == Just path 21 | -------------------------------------------------------------------------------- /09/src/Adapter/HTTP/Web/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Web.Common where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Domain.Auth 6 | import qualified Text.Digestive.View as DF 7 | import Text.Blaze.Html5 ((!)) 8 | import qualified Text.Blaze.Html5 as H 9 | import qualified Text.Blaze.Html5.Attributes as A 10 | import qualified Text.Blaze.Html.Renderer.Text as H 11 | import Adapter.HTTP.Common 12 | 13 | -- * Views 14 | 15 | renderHtml :: (ScottyError e, Monad m) => H.Html -> ActionT e m () 16 | renderHtml = html . H.renderHtml 17 | 18 | mainLayout :: Text -> H.Html -> H.Html 19 | mainLayout title content = 20 | H.docTypeHtml $ do 21 | H.head $ do 22 | favicon "/images/logo.png" 23 | H.title $ H.toHtml title 24 | H.body $ do 25 | H.div $ H.img ! A.src "/images/logo.png" 26 | H.div content 27 | where 28 | favicon path = 29 | H.link ! A.rel "icon" 30 | ! A.type_ "image/png" 31 | ! A.href path 32 | 33 | formLayout :: DF.View a -> Text -> H.Html -> H.Html 34 | formLayout view action = 35 | H.form ! A.method "POST" 36 | ! A.enctype (H.toValue $ show $ DF.viewEncType view) 37 | ! A.action (H.toValue action) 38 | 39 | -- * Sessions 40 | 41 | reqCurrentUserId :: (SessionRepo m, ScottyError e) => ActionT e m UserId 42 | reqCurrentUserId = do 43 | mUserId <- getCurrentUserId 44 | case mUserId of 45 | Nothing -> 46 | redirect "/auth/login" 47 | Just userId -> 48 | return userId -------------------------------------------------------------------------------- /09/src/Adapter/HTTP/Web/Main.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Web.Main where 2 | 3 | import Domain.Auth 4 | import ClassyPrelude 5 | import Web.Scotty.Trans 6 | import Network.HTTP.Types.Status 7 | import qualified Adapter.HTTP.Web.Auth as Auth 8 | import Katip 9 | import Network.Wai 10 | import Network.Wai.Middleware.Static 11 | import Network.Wai.Middleware.Gzip 12 | 13 | main :: ( MonadIO m, KatipContext m, AuthRepo m 14 | , EmailVerificationNotif m, SessionRepo m) 15 | => (m Response -> IO Response) -> IO Application 16 | main runner = do 17 | cacheContainer <- initCaching PublicStaticCaching 18 | scottyAppT runner $ routes cacheContainer 19 | 20 | routes :: ( MonadIO m, KatipContext m, AuthRepo m 21 | , EmailVerificationNotif m, SessionRepo m) 22 | => CacheContainer -> ScottyT LText m () 23 | routes cacheContainer = do 24 | middleware $ 25 | gzip $ def { gzipFiles = GzipCompress } 26 | middleware $ 27 | staticPolicy' cacheContainer (addBase "src/Adapter/HTTP/Web/static") 28 | 29 | Auth.routes 30 | 31 | notFound $ do 32 | status status404 33 | text "Not found" 34 | 35 | defaultHandler $ \e -> do 36 | lift $ $(logTM) ErrorS $ "Unhandled error: " <> ls (showError e) 37 | status status500 38 | text "Internal server error!" 39 | -------------------------------------------------------------------------------- /09/src/Adapter/HTTP/Web/static/images/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-webdev-haskell/17b90c06030def254bb0497b9e357f5d3b96d0cf/09/src/Adapter/HTTP/Web/static/images/logo.png -------------------------------------------------------------------------------- /09/src/Adapter/PostgreSQL/Migrations/00000_auths.sql: -------------------------------------------------------------------------------- 1 | create extension citext; 2 | create extension pgcrypto; 3 | 4 | create table auths ( 5 | id bigserial primary key not null, 6 | pass text not null, 7 | email citext not null unique, 8 | email_verification_code text not null, 9 | is_email_verified boolean not null 10 | ); -------------------------------------------------------------------------------- /09/src/Adapter/RabbitMQ/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.RabbitMQ.Auth where 2 | 3 | import ClassyPrelude 4 | import Adapter.RabbitMQ.Common 5 | import qualified Adapter.InMemory.Auth as M 6 | import Network.AMQP 7 | import Katip 8 | import Data.Aeson 9 | import Data.Aeson.TH 10 | import qualified Domain.Auth as D 11 | 12 | data EmailVerificationPayload = EmailVerificationPayload 13 | { emailVerificationPayloadEmail :: Text 14 | , emailVerificationPayloadVerificationCode :: Text 15 | } 16 | 17 | init :: (M.InMemory r m, KatipContext m, MonadCatch m) 18 | => State -> (m Bool -> IO Bool) -> IO () 19 | init state runner = do 20 | initQueue state "verifyEmail" "auth" "userRegistered" 21 | initConsumer state "verifyEmail" (consumeEmailVerification runner) 22 | 23 | consumeEmailVerification :: (M.InMemory r m, KatipContext m, MonadCatch m) 24 | => (m Bool -> IO Bool) -> Message -> IO Bool 25 | consumeEmailVerification runner msg = 26 | runner $ consumeAndProcess msg handler 27 | where 28 | handler payload = do 29 | case D.mkEmail (emailVerificationPayloadEmail payload) of 30 | Left err -> withMsgAndErr msg err $ do 31 | $(logTM) ErrorS "Email format is invalid. Rejecting." 32 | return False 33 | Right email -> do 34 | let vCode = emailVerificationPayloadVerificationCode payload 35 | M.notifyEmailVerification email vCode 36 | return True 37 | 38 | notifyEmailVerification :: (Rabbit r m) => D.Email -> D.VerificationCode -> m () 39 | notifyEmailVerification email vCode = 40 | let payload = EmailVerificationPayload (D.rawEmail email) vCode 41 | in publish "auth" "userRegistered" payload 42 | 43 | -- JSON serde 44 | 45 | $(let structName = fromMaybe "" . lastMay . splitElem '.' . show $ ''EmailVerificationPayload 46 | lowercaseFirst (x:xs) = toLower [x] <> xs 47 | lowercaseFirst xs = xs 48 | options = defaultOptions 49 | { fieldLabelModifier = lowercaseFirst . drop (length structName) 50 | } 51 | in deriveJSON options ''EmailVerificationPayload) -------------------------------------------------------------------------------- /09/src/Adapter/Redis/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Redis.Auth where 2 | 3 | import ClassyPrelude 4 | import qualified Domain.Auth as D 5 | import Text.StringRandom 6 | import Data.Has 7 | import qualified Database.Redis as R 8 | 9 | type State = R.Connection 10 | 11 | type Redis r m = (Has State r, MonadReader r m, MonadIO m) 12 | 13 | -- | Create state from redis url string. 14 | -- format: redis://user:pass@host:port/db 15 | -- sample: redis://abc:def@localhost:6379/0 16 | withState :: String -> (State -> IO a) -> IO a 17 | withState connUrl action = do 18 | let connInfo = either (error "Invalid Redis conn URL") id $ R.parseConnectInfo connUrl 19 | conn <- R.checkedConnect connInfo 20 | action conn 21 | 22 | withConn :: Redis r m => R.Redis a -> m a 23 | withConn action = do 24 | conn <- asks getter 25 | liftIO $ R.runRedis conn action 26 | 27 | newSession :: Redis r m => D.UserId -> m D.SessionId 28 | newSession userId = do 29 | sId <- liftIO $ stringRandomIO "[a-zA-Z0-9]{32}" 30 | result <- withConn $ R.set (encodeUtf8 sId) (fromString . show $ userId) 31 | case result of 32 | Right R.Ok -> return sId 33 | err -> error $ "Unexpected redis error: " <> show err 34 | 35 | findUserIdBySessionId :: Redis r m => D.SessionId -> m (Maybe D.UserId) 36 | findUserIdBySessionId sId = do 37 | result <- withConn $ R.get (encodeUtf8 sId) 38 | return $ case result of 39 | Right (Just uIdStr) -> readMay . unpack . decodeUtf8 $ uIdStr 40 | err -> error $ "Unexpected redis error: " <> show err -------------------------------------------------------------------------------- /09/src/Domain/Validation.hs: -------------------------------------------------------------------------------- 1 | module Domain.Validation where 2 | 3 | import ClassyPrelude 4 | import Text.Regex.PCRE.Heavy 5 | 6 | type ErrMsg = Text 7 | type Validation a = a -> Maybe ErrMsg 8 | 9 | validate :: (a -> b) -> [Validation a] -> a -> Either [ErrMsg] b 10 | validate constructor validations val = 11 | case concatMap (\f -> maybeToList $ f val) validations of 12 | [] -> Right $ constructor val 13 | errs -> Left errs 14 | 15 | rangeBetween :: (Ord a) => a -> a -> ErrMsg -> Validation a 16 | rangeBetween minRange maxRange msg val = 17 | if val >= minRange && val <= maxRange then Nothing else Just msg 18 | 19 | lengthBetween :: (MonoFoldable a) => Int -> Int -> ErrMsg -> Validation a 20 | lengthBetween minLen maxLen msg val = 21 | rangeBetween minLen maxLen msg (length val) 22 | 23 | regexMatches :: Regex -> ErrMsg -> Validation Text 24 | regexMatches regex msg val = 25 | if val =~ regex then Nothing else Just msg 26 | -------------------------------------------------------------------------------- /09/test/Spec.hs: -------------------------------------------------------------------------------- 1 | import ClassyPrelude 2 | 3 | main :: IO () 4 | main = putStrLn "Test suite not yet implemented" 5 | -------------------------------------------------------------------------------- /10/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | .hspec-failures 3 | *.tix 4 | .DS_Store 5 | *.cabal 6 | -------------------------------------------------------------------------------- /10/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 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 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /10/README.md: -------------------------------------------------------------------------------- 1 | # hauth 2 | -------------------------------------------------------------------------------- /10/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /10/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ClassyPrelude 4 | import qualified Lib as Lib 5 | 6 | main :: IO () 7 | main = Lib.main 8 | -------------------------------------------------------------------------------- /10/package.yaml: -------------------------------------------------------------------------------- 1 | name: hauth 2 | version: '0.1.0.0' 3 | category: Web 4 | author: Ecky Putrady 5 | maintainer: eckyp@example.com 6 | copyright: 2017 Ecky Putrady 7 | license: BSD3 8 | github: githubuser/hauth 9 | extra-source-files: 10 | - README.md 11 | 12 | dependencies: 13 | - base 14 | - classy-prelude 15 | - pcre-heavy 16 | - time-lens 17 | - time 18 | - aeson 19 | - mtl 20 | - string-random 21 | - data-has 22 | - katip 23 | - postgresql-simple 24 | - postgresql-simple-migration 25 | - resource-pool 26 | - hedis 27 | - amqp 28 | - http-types 29 | - scotty 30 | - cookie 31 | - wai 32 | - wai-extra 33 | - blaze-builder 34 | - digestive-functors 35 | - digestive-functors-aeson 36 | - blaze-html 37 | - digestive-functors-blaze 38 | - digestive-functors-scotty 39 | - wai-middleware-static 40 | - warp 41 | - http-client 42 | - http-client-tls 43 | - template-haskell 44 | 45 | default-extensions: 46 | - NoImplicitPrelude 47 | - OverloadedStrings 48 | - QuasiQuotes 49 | - GeneralizedNewtypeDeriving 50 | - ConstraintKinds 51 | - FlexibleContexts 52 | - TemplateHaskell 53 | 54 | library: 55 | source-dirs: src 56 | executables: 57 | hauth-exe: 58 | main: Main.hs 59 | source-dirs: app 60 | ghc-options: 61 | - -threaded 62 | - -rtsopts 63 | - -with-rtsopts=-N 64 | dependencies: 65 | - hauth 66 | tests: 67 | hauth-test: 68 | main: Spec.hs 69 | source-dirs: test 70 | ghc-options: 71 | - -threaded 72 | - -rtsopts 73 | - -with-rtsopts=-N 74 | dependencies: 75 | - hauth 76 | -------------------------------------------------------------------------------- /10/src/Adapter/HTTP/API/Client/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Client.Auth where 2 | 3 | import ClassyPrelude 4 | import Network.HTTP.Client 5 | import Data.Has 6 | import qualified Domain.Auth as D 7 | import Network.HTTP.Types 8 | import Adapter.HTTP.API.Types.Auth () 9 | import Adapter.HTTP.API.Client.Common 10 | import Data.Aeson 11 | 12 | register :: HttpClient r m => D.Auth -> m (Either D.RegistrationError ()) 13 | register auth = do 14 | State initReq mgr <- asks getter 15 | let req = initReq 16 | { method = "POST" 17 | , path = "/api/auth/register" 18 | , requestBody = RequestBodyLBS $ encode auth 19 | } 20 | resp <- liftIO $ httpLbs req mgr 21 | case responseStatus resp of 22 | (Status 200 _) -> 23 | return $ Right () 24 | _ -> 25 | Left <$> parseOrErr req resp 26 | 27 | verifyEmail :: HttpClient r m 28 | => D.VerificationCode -> m (Either D.EmailVerificationError ()) 29 | verifyEmail code = do 30 | State initReq mgr <- asks getter 31 | let req = initReq 32 | { method = "POST" 33 | , path = "/api/auth/verifyEmail" 34 | , requestBody = RequestBodyLBS . encode $ code 35 | } 36 | resp <- liftIO $ httpLbs req mgr 37 | case responseStatus resp of 38 | (Status 200 _) -> 39 | return $ Right () 40 | _ -> 41 | Left <$> parseOrErr req resp 42 | 43 | login :: HttpClient r m => D.Auth -> m (Either D.LoginError Session) 44 | login auth = do 45 | State initReq mgr <- asks getter 46 | let req = initReq 47 | { method = "POST" 48 | , path = "/api/auth/login" 49 | , requestBody = RequestBodyLBS $ encode auth 50 | } 51 | resp <- liftIO $ httpLbs req mgr 52 | case responseStatus resp of 53 | (Status 200 _) -> 54 | return $ Right $ responseCookieJar resp 55 | _ -> 56 | Left <$> parseOrErr req resp 57 | 58 | getUser :: HttpClient r m => Session -> m D.Email 59 | getUser session = do 60 | State initReq mgr <- asks getter 61 | let req = initReq 62 | { method = "GET" 63 | , path = "/api/users" 64 | , cookieJar = Just session 65 | } 66 | resp <- liftIO $ httpLbs req mgr 67 | case responseStatus resp of 68 | (Status 200 _) -> 69 | parseOrErr req resp 70 | _ -> 71 | throw $ UnexpectedResponse req resp -------------------------------------------------------------------------------- /10/src/Adapter/HTTP/API/Client/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Client.Common where 2 | 3 | import ClassyPrelude 4 | import Network.HTTP.Client 5 | import Network.HTTP.Client.TLS 6 | import Data.Has 7 | import Data.Aeson 8 | 9 | newtype Config = Config 10 | { configUrl :: String 11 | } 12 | 13 | data State = State 14 | { stateInitReq :: Request 15 | , stateManager :: Manager 16 | } 17 | 18 | type HttpClient r m = (MonadReader r m, Has State r, MonadIO m, MonadThrow m) 19 | 20 | type Session = CookieJar 21 | 22 | data UnexpectedResponse a = 23 | UnexpectedResponse Request (Response a) deriving (Show) 24 | 25 | instance (Typeable a, Show a) => Exception (UnexpectedResponse a) 26 | 27 | -- * Initialize 28 | 29 | withState :: Config -> (State -> IO a) -> IO a 30 | withState cfg action = do 31 | mgr <- newManager tlsManagerSettings 32 | initReq <- parseRequest $ configUrl cfg 33 | let initReqWithJson = 34 | initReq { requestHeaders = 35 | [("Content-Type", "application/json; charset=utf-8")] 36 | } 37 | action $ State initReqWithJson mgr 38 | 39 | -- * Helpers 40 | 41 | parseOrErr :: (MonadThrow m, FromJSON a) 42 | => Request -> Response LByteString -> m a 43 | parseOrErr req resp = 44 | case eitherDecode' $ responseBody resp of 45 | Left _ -> throw $ UnexpectedResponse req resp 46 | Right a -> return a -------------------------------------------------------------------------------- /10/src/Adapter/HTTP/API/Server/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Server.Auth where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Domain.Auth 6 | import qualified Text.Digestive.Form as DF 7 | import Text.Digestive.Form ((.:)) 8 | import Adapter.HTTP.Common 9 | import Adapter.HTTP.API.Server.Common 10 | import Adapter.HTTP.API.Types.Auth () 11 | import Network.HTTP.Types.Status 12 | import Katip 13 | 14 | -- * Routes 15 | 16 | routes :: ( ScottyError e, MonadIO m, KatipContext m, AuthRepo m 17 | , EmailVerificationNotif m, SessionRepo m) 18 | => ScottyT e m () 19 | routes = do 20 | -- register 21 | post "/api/auth/register" $ do 22 | input <- parseAndValidateJSON authForm 23 | domainResult <- lift $ register input 24 | case domainResult of 25 | Left err -> do 26 | status status400 27 | json err 28 | Right _ -> 29 | return () 30 | 31 | -- verify email 32 | post "/api/auth/verifyEmail" $ do 33 | input <- parseAndValidateJSON verifyEmailForm 34 | domainResult <- lift $ verifyEmail input 35 | case domainResult of 36 | Left err -> do 37 | status status400 38 | json err 39 | Right _ -> 40 | return () 41 | 42 | -- login 43 | post "/api/auth/login" $ do 44 | input <- parseAndValidateJSON authForm 45 | domainResult <- lift $ login input 46 | case domainResult of 47 | Left err -> do 48 | status status400 49 | json err 50 | Right sId -> do 51 | setSessionIdInCookie sId 52 | return () 53 | 54 | -- get user 55 | get "/api/users" $ do 56 | userId <- reqCurrentUserId 57 | mayEmail <- lift $ getUser userId 58 | case mayEmail of 59 | Nothing -> 60 | raise $ stringError "Should not happen: SessionId map to invalid UserId" 61 | Just email -> 62 | json email 63 | 64 | -- * Forms 65 | 66 | verifyEmailForm :: (Monad m) => DF.Form [Text] m VerificationCode 67 | verifyEmailForm = DF.text Nothing 68 | 69 | authForm :: (Monad m) => DF.Form [Text] m Auth 70 | authForm = 71 | Auth <$> "email" .: emailForm 72 | <*> "password" .: passwordForm 73 | where 74 | emailForm = DF.validate (toResult . mkEmail) (DF.text Nothing) 75 | passwordForm = DF.validate (toResult . mkPassword) (DF.text Nothing) -------------------------------------------------------------------------------- /10/src/Adapter/HTTP/API/Server/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Server.Common where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Domain.Auth 6 | import qualified Text.Digestive.Form as DF 7 | import qualified Text.Digestive.Aeson as DF 8 | import Data.Aeson hiding (json) 9 | import Network.HTTP.Types.Status 10 | import Adapter.HTTP.Common 11 | 12 | -- * Forms 13 | 14 | parseAndValidateJSON :: (ScottyError e, MonadIO m, ToJSON v) 15 | => DF.Form v m a -> ActionT e m a 16 | parseAndValidateJSON form = do 17 | val <- jsonData `rescue` (\_ -> return Null) 18 | validationResult <- lift $ DF.digestJSON form val 19 | case validationResult of 20 | (v, Nothing) -> do 21 | status status400 22 | json $ DF.jsonErrors v 23 | finish 24 | (_, Just result) -> 25 | return result 26 | 27 | -- * Sessions 28 | 29 | reqCurrentUserId :: (SessionRepo m, ScottyError e) => ActionT e m UserId 30 | reqCurrentUserId = do 31 | mayUserId <- getCurrentUserId 32 | case mayUserId of 33 | Nothing -> do 34 | status status401 35 | json ("AuthRequired" :: Text) 36 | finish 37 | Just userId -> 38 | return userId -------------------------------------------------------------------------------- /10/src/Adapter/HTTP/API/Server/Main.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Server.Main where 2 | 3 | import Domain.Auth 4 | import ClassyPrelude 5 | import Web.Scotty.Trans 6 | import Network.HTTP.Types.Status 7 | import qualified Adapter.HTTP.API.Server.Auth as Auth 8 | import Adapter.HTTP.API.Server.Common 9 | import Katip 10 | import Network.Wai 11 | import Network.Wai.Middleware.Gzip 12 | 13 | main :: ( MonadIO m, KatipContext m, AuthRepo m 14 | , EmailVerificationNotif m, SessionRepo m) 15 | => (m Response -> IO Response) -> IO Application 16 | main runner = 17 | scottyAppT runner routes 18 | 19 | routes :: ( MonadIO m, KatipContext m, AuthRepo m 20 | , EmailVerificationNotif m, SessionRepo m) 21 | => ScottyT LText m () 22 | routes = do 23 | middleware $ gzip $ def { gzipFiles = GzipCompress } 24 | 25 | Auth.routes 26 | 27 | notFound $ do 28 | status status404 29 | json ("NotFound" :: Text) 30 | 31 | defaultHandler $ \e -> do 32 | lift $ $(logTM) ErrorS $ "Unhandled error: " <> ls (showError e) 33 | status status500 34 | json ("InternalServerError" :: Text) 35 | -------------------------------------------------------------------------------- /10/src/Adapter/HTTP/API/Types/AesonHelper.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Types.AesonHelper where 2 | 3 | import ClassyPrelude 4 | import Data.Aeson.TH 5 | import Data.Aeson.Types 6 | import Language.Haskell.TH.Syntax 7 | 8 | withSmartConstructor :: (a -> Either [Text] b) -> a -> Parser b 9 | withSmartConstructor constructor a = 10 | case constructor a of 11 | Left errs -> fail $ intercalate ". " . map unpack $ errs 12 | Right val -> return val 13 | 14 | deriveJSONRecord :: Name -> Q [Dec] 15 | deriveJSONRecord record = 16 | let lowerCaseFirst (y:ys) = toLower [y] <> ys 17 | lowerCaseFirst "" = "" 18 | structName = nameBase record 19 | opts = defaultOptions 20 | { fieldLabelModifier = lowerCaseFirst . drop (length structName) 21 | } 22 | in deriveJSON opts record 23 | 24 | deriveJSONSumType :: Name -> Q [Dec] 25 | deriveJSONSumType record = 26 | let structName = nameBase record 27 | opts = defaultOptions 28 | { constructorTagModifier = drop (length structName) 29 | , tagSingleConstructors = True 30 | } 31 | in deriveJSON opts record 32 | 33 | deriveToJSONUnwrap :: Name -> Q [Dec] 34 | deriveToJSONUnwrap = 35 | let opts = defaultOptions { unwrapUnaryRecords = True } 36 | in deriveToJSON opts -------------------------------------------------------------------------------- /10/src/Adapter/HTTP/API/Types/Auth.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Adapter.HTTP.API.Types.Auth where 4 | 5 | import ClassyPrelude 6 | import Domain.Auth 7 | import Data.Aeson 8 | import Adapter.HTTP.API.Types.AesonHelper 9 | 10 | instance FromJSON Email where 11 | parseJSON = 12 | withText "Email" $ withSmartConstructor mkEmail 13 | 14 | instance FromJSON Password where 15 | parseJSON = 16 | withText "Password" $ withSmartConstructor mkPassword 17 | 18 | $(map concat . sequence $ 19 | [ deriveJSONRecord ''Auth 20 | , deriveToJSONUnwrap ''Email 21 | , deriveToJSONUnwrap ''Password 22 | , deriveJSONSumType ''RegistrationError 23 | , deriveJSONSumType ''EmailVerificationError 24 | , deriveJSONSumType ''LoginError 25 | ]) -------------------------------------------------------------------------------- /10/src/Adapter/HTTP/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Common where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Blaze.ByteString.Builder (toLazyByteString) 6 | import Web.Cookie 7 | import Domain.Auth 8 | import Data.Time.Lens 9 | import qualified Text.Digestive.Types as DF 10 | 11 | -- * Forms 12 | 13 | toResult :: Either e a -> DF.Result e a 14 | toResult = either DF.Error DF.Success 15 | 16 | -- * Cookies 17 | 18 | setCookie :: (ScottyError e, Monad m) => SetCookie -> ActionT e m () 19 | setCookie = setHeader "Set-Cookie" . decodeUtf8 . toLazyByteString . renderSetCookie 20 | 21 | getCookie :: (ScottyError e, Monad m) => Text -> ActionT e m (Maybe Text) 22 | getCookie key = do 23 | mCookieStr <- header "Cookie" 24 | return $ do 25 | cookie <- parseCookies . encodeUtf8 . toStrict <$> mCookieStr 26 | let bsKey = encodeUtf8 key 27 | val <- lookup bsKey cookie 28 | return $ decodeUtf8 val 29 | 30 | -- * Sessions 31 | 32 | setSessionIdInCookie :: (MonadIO m, ScottyError e) => SessionId -> ActionT e m () 33 | setSessionIdInCookie sId = do 34 | curTime <- liftIO getCurrentTime 35 | setCookie $ def { setCookieName = "sId" 36 | , setCookiePath = Just "/" 37 | , setCookieValue = encodeUtf8 sId 38 | , setCookieExpires = Just $ modL month (+ 1) curTime 39 | , setCookieHttpOnly = True 40 | , setCookieSecure = False 41 | , setCookieSameSite = Just sameSiteLax 42 | } 43 | 44 | getCurrentUserId :: (SessionRepo m, ScottyError e) => ActionT e m (Maybe UserId) 45 | getCurrentUserId = do 46 | maySessionId <- getCookie "sId" 47 | case maySessionId of 48 | Nothing -> return Nothing 49 | Just sId -> lift $ resolveSessionId sId -------------------------------------------------------------------------------- /10/src/Adapter/HTTP/Main.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Main where 2 | 3 | import Domain.Auth 4 | import ClassyPrelude 5 | import qualified Adapter.HTTP.API.Server.Main as API 6 | import qualified Adapter.HTTP.Web.Main as Web 7 | import Katip 8 | import Network.Wai 9 | import Network.Wai.Handler.Warp 10 | import Network.Wai.Middleware.Vhost 11 | 12 | main :: ( MonadIO m, KatipContext m, AuthRepo m 13 | , EmailVerificationNotif m, SessionRepo m) 14 | => Int -> (m Response -> IO Response) -> IO () 15 | main port runner = do 16 | web <- Web.main runner 17 | api <- API.main runner 18 | run port $ vhost [(pathBeginsWith "api", api)] web 19 | where 20 | pathBeginsWith path req = headMay (pathInfo req) == Just path 21 | -------------------------------------------------------------------------------- /10/src/Adapter/HTTP/Web/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Web.Common where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Domain.Auth 6 | import qualified Text.Digestive.View as DF 7 | import Text.Blaze.Html5 ((!)) 8 | import qualified Text.Blaze.Html5 as H 9 | import qualified Text.Blaze.Html5.Attributes as A 10 | import qualified Text.Blaze.Html.Renderer.Text as H 11 | import Adapter.HTTP.Common 12 | 13 | -- * Views 14 | 15 | renderHtml :: (ScottyError e, Monad m) => H.Html -> ActionT e m () 16 | renderHtml = html . H.renderHtml 17 | 18 | mainLayout :: Text -> H.Html -> H.Html 19 | mainLayout title content = 20 | H.docTypeHtml $ do 21 | H.head $ do 22 | favicon "/images/logo.png" 23 | H.title $ H.toHtml title 24 | H.body $ do 25 | H.div $ H.img ! A.src "/images/logo.png" 26 | H.div content 27 | where 28 | favicon path = 29 | H.link ! A.rel "icon" 30 | ! A.type_ "image/png" 31 | ! A.href path 32 | 33 | formLayout :: DF.View a -> Text -> H.Html -> H.Html 34 | formLayout view action = 35 | H.form ! A.method "POST" 36 | ! A.enctype (H.toValue $ show $ DF.viewEncType view) 37 | ! A.action (H.toValue action) 38 | 39 | -- * Sessions 40 | 41 | reqCurrentUserId :: (SessionRepo m, ScottyError e) => ActionT e m UserId 42 | reqCurrentUserId = do 43 | mUserId <- getCurrentUserId 44 | case mUserId of 45 | Nothing -> 46 | redirect "/auth/login" 47 | Just userId -> 48 | return userId -------------------------------------------------------------------------------- /10/src/Adapter/HTTP/Web/Main.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Web.Main where 2 | 3 | import Domain.Auth 4 | import ClassyPrelude 5 | import Web.Scotty.Trans 6 | import Network.HTTP.Types.Status 7 | import qualified Adapter.HTTP.Web.Auth as Auth 8 | import Katip 9 | import Network.Wai 10 | import Network.Wai.Middleware.Static 11 | import Network.Wai.Middleware.Gzip 12 | 13 | main :: ( MonadIO m, KatipContext m, AuthRepo m 14 | , EmailVerificationNotif m, SessionRepo m) 15 | => (m Response -> IO Response) -> IO Application 16 | main runner = do 17 | cacheContainer <- initCaching PublicStaticCaching 18 | scottyAppT runner $ routes cacheContainer 19 | 20 | routes :: ( MonadIO m, KatipContext m, AuthRepo m 21 | , EmailVerificationNotif m, SessionRepo m) 22 | => CacheContainer -> ScottyT LText m () 23 | routes cacheContainer = do 24 | middleware $ 25 | gzip $ def { gzipFiles = GzipCompress } 26 | middleware $ 27 | staticPolicy' cacheContainer (addBase "src/Adapter/HTTP/Web/static") 28 | 29 | Auth.routes 30 | 31 | notFound $ do 32 | status status404 33 | text "Not found" 34 | 35 | defaultHandler $ \e -> do 36 | lift $ $(logTM) ErrorS $ "Unhandled error: " <> ls (showError e) 37 | status status500 38 | text "Internal server error!" 39 | -------------------------------------------------------------------------------- /10/src/Adapter/HTTP/Web/static/images/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-webdev-haskell/17b90c06030def254bb0497b9e357f5d3b96d0cf/10/src/Adapter/HTTP/Web/static/images/logo.png -------------------------------------------------------------------------------- /10/src/Adapter/PostgreSQL/Migrations/00000_auths.sql: -------------------------------------------------------------------------------- 1 | create extension citext; 2 | create extension pgcrypto; 3 | 4 | create table auths ( 5 | id bigserial primary key not null, 6 | pass text not null, 7 | email citext not null unique, 8 | email_verification_code text not null, 9 | is_email_verified boolean not null 10 | ); -------------------------------------------------------------------------------- /10/src/Adapter/RabbitMQ/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.RabbitMQ.Auth where 2 | 3 | import ClassyPrelude 4 | import Adapter.RabbitMQ.Common 5 | import qualified Adapter.InMemory.Auth as M 6 | import Network.AMQP 7 | import Katip 8 | import Data.Aeson 9 | import Data.Aeson.TH 10 | import qualified Domain.Auth as D 11 | 12 | data EmailVerificationPayload = EmailVerificationPayload 13 | { emailVerificationPayloadEmail :: Text 14 | , emailVerificationPayloadVerificationCode :: Text 15 | } 16 | 17 | init :: (M.InMemory r m, KatipContext m, MonadCatch m) 18 | => State -> (m Bool -> IO Bool) -> IO () 19 | init state runner = do 20 | initQueue state "verifyEmail" "auth" "userRegistered" 21 | initConsumer state "verifyEmail" (consumeEmailVerification runner) 22 | 23 | consumeEmailVerification :: (M.InMemory r m, KatipContext m, MonadCatch m) 24 | => (m Bool -> IO Bool) -> Message -> IO Bool 25 | consumeEmailVerification runner msg = 26 | runner $ consumeAndProcess msg handler 27 | where 28 | handler payload = 29 | case D.mkEmail (emailVerificationPayloadEmail payload) of 30 | Left err -> withMsgAndErr msg err $ do 31 | $(logTM) ErrorS "Email format is invalid. Rejecting." 32 | return False 33 | Right email -> do 34 | let vCode = emailVerificationPayloadVerificationCode payload 35 | M.notifyEmailVerification email vCode 36 | return True 37 | 38 | notifyEmailVerification :: (Rabbit r m) => D.Email -> D.VerificationCode -> m () 39 | notifyEmailVerification email vCode = 40 | let payload = EmailVerificationPayload (D.rawEmail email) vCode 41 | in publish "auth" "userRegistered" payload 42 | 43 | -- JSON serde 44 | 45 | $(let structName = fromMaybe "" . lastMay . splitElem '.' . show $ ''EmailVerificationPayload 46 | lowercaseFirst (x:xs) = toLower [x] <> xs 47 | lowercaseFirst xs = xs 48 | options = defaultOptions 49 | { fieldLabelModifier = lowercaseFirst . drop (length structName) 50 | } 51 | in deriveJSON options ''EmailVerificationPayload) -------------------------------------------------------------------------------- /10/src/Adapter/Redis/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Redis.Auth where 2 | 3 | import ClassyPrelude 4 | import qualified Domain.Auth as D 5 | import Text.StringRandom 6 | import Data.Has 7 | import qualified Database.Redis as R 8 | 9 | type State = R.Connection 10 | 11 | type Redis r m = (Has State r, MonadReader r m, MonadIO m, MonadThrow m) 12 | 13 | -- | Create state from redis url string. 14 | -- format: redis://user:pass@host:port/db 15 | -- sample: redis://abc:def@localhost:6379/0 16 | withState :: String -> (State -> IO a) -> IO a 17 | withState connUrl action = 18 | case R.parseConnectInfo connUrl of 19 | Left _ -> 20 | throwString $ "Invalid Redis conn URL: " <> connUrl 21 | Right connInfo -> do 22 | conn <- R.checkedConnect connInfo 23 | action conn 24 | 25 | withConn :: Redis r m => R.Redis a -> m a 26 | withConn action = do 27 | conn <- asks getter 28 | liftIO $ R.runRedis conn action 29 | 30 | newSession :: Redis r m => D.UserId -> m D.SessionId 31 | newSession userId = do 32 | sId <- liftIO $ stringRandomIO "[a-zA-Z0-9]{32}" 33 | result <- withConn $ R.set (encodeUtf8 sId) (fromString . show $ userId) 34 | case result of 35 | Right R.Ok -> return sId 36 | err -> throwString $ "Unexpected redis error: " <> show err 37 | 38 | findUserIdBySessionId :: Redis r m => D.SessionId -> m (Maybe D.UserId) 39 | findUserIdBySessionId sId = do 40 | result <- withConn $ R.get (encodeUtf8 sId) 41 | return $ case result of 42 | Right (Just uIdStr) -> readMay . unpack . decodeUtf8 $ uIdStr 43 | err -> throwString $ "Unexpected redis error: " <> show err -------------------------------------------------------------------------------- /10/src/Config.hs: -------------------------------------------------------------------------------- 1 | module Config where 2 | 3 | import ClassyPrelude 4 | import System.Environment 5 | import qualified Adapter.PostgreSQL.Auth as PG 6 | import qualified Adapter.RabbitMQ.Common as MQ 7 | 8 | data Config = Config 9 | { configPort :: Int 10 | , configRedis :: String 11 | , configMQ :: MQ.Config 12 | , configPG :: PG.Config 13 | } 14 | 15 | fromEnv :: IO Config 16 | fromEnv = Config 17 | <$> envRead "PORT" 18 | <*> getEnv "REDIS_URL" 19 | <*> (MQ.Config 20 | <$> getEnv "MQ_URL" 21 | <*> pure 16 22 | ) 23 | <*> (PG.Config 24 | <$> envFromString "PG_URL" 25 | <*> pure 2 26 | <*> pure 5 27 | <*> pure 10 28 | ) 29 | 30 | devConfig :: Config 31 | devConfig = Config 32 | { configPort = 3000 33 | , configRedis = "redis://localhost:6379/0" 34 | , configMQ = MQ.Config 35 | { MQ.configUrl = "amqp://guest:guest@localhost:5672/%2F" 36 | , MQ.configPrefetchCount = 16 37 | } 38 | , configPG = PG.Config 39 | { PG.configUrl = "postgresql://localhost/hauth" 40 | , PG.configStripeCount = 2 41 | , PG.configMaxOpenConnPerStripe = 5 42 | , PG.configIdleConnTimeout = 10 43 | } 44 | } 45 | 46 | -- * Helpers 47 | 48 | envFromString :: (IsString a) => String -> IO a 49 | envFromString key = fromString <$> getEnv key 50 | 51 | envRead :: Read a => String -> IO a 52 | envRead key = do 53 | rawVal <- getEnv key 54 | case readMay rawVal of 55 | Just val -> return val 56 | Nothing -> throwString $ key <> ": Unable to parse " <> rawVal 57 | -------------------------------------------------------------------------------- /10/src/Domain/Validation.hs: -------------------------------------------------------------------------------- 1 | module Domain.Validation where 2 | 3 | import ClassyPrelude 4 | import Text.Regex.PCRE.Heavy 5 | 6 | type ErrMsg = Text 7 | type Validation a = a -> Maybe ErrMsg 8 | 9 | validate :: (a -> b) -> [Validation a] -> a -> Either [ErrMsg] b 10 | validate constructor validations val = 11 | case concatMap (\f -> maybeToList $ f val) validations of 12 | [] -> Right $ constructor val 13 | errs -> Left errs 14 | 15 | rangeBetween :: (Ord a) => a -> a -> ErrMsg -> Validation a 16 | rangeBetween minRange maxRange msg val = 17 | if val >= minRange && val <= maxRange then Nothing else Just msg 18 | 19 | lengthBetween :: (MonoFoldable a) => Int -> Int -> ErrMsg -> Validation a 20 | lengthBetween minLen maxLen msg val = 21 | rangeBetween minLen maxLen msg (length val) 22 | 23 | regexMatches :: Regex -> ErrMsg -> Validation Text 24 | regexMatches regex msg val = 25 | if val =~ regex then Nothing else Just msg 26 | -------------------------------------------------------------------------------- /10/test/Spec.hs: -------------------------------------------------------------------------------- 1 | import ClassyPrelude 2 | 3 | main :: IO () 4 | main = putStrLn "Test suite not yet implemented" 5 | -------------------------------------------------------------------------------- /11/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | .hspec-failures 3 | *.tix 4 | .DS_Store 5 | *.cabal 6 | -------------------------------------------------------------------------------- /11/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 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 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /11/README.md: -------------------------------------------------------------------------------- 1 | # hauth 2 | -------------------------------------------------------------------------------- /11/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /11/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ClassyPrelude 4 | import qualified Lib as Lib 5 | 6 | main :: IO () 7 | main = Lib.main 8 | -------------------------------------------------------------------------------- /11/package.yaml: -------------------------------------------------------------------------------- 1 | name: hauth 2 | version: '0.1.0.0' 3 | category: Web 4 | author: Ecky Putrady 5 | maintainer: eckyp@example.com 6 | copyright: 2017 Ecky Putrady 7 | license: BSD3 8 | github: githubuser/hauth 9 | extra-source-files: 10 | - README.md 11 | 12 | dependencies: 13 | - base 14 | - classy-prelude 15 | - pcre-heavy 16 | - time-lens 17 | - time 18 | - aeson 19 | - mtl 20 | - string-random 21 | - data-has 22 | - katip 23 | - postgresql-simple 24 | - postgresql-simple-migration 25 | - resource-pool 26 | - hedis 27 | - amqp 28 | - http-types 29 | - scotty 30 | - cookie 31 | - wai 32 | - wai-extra 33 | - blaze-builder 34 | - digestive-functors 35 | - digestive-functors-aeson 36 | - blaze-html 37 | - digestive-functors-blaze 38 | - digestive-functors-scotty 39 | - wai-middleware-static 40 | - warp 41 | - http-client 42 | - http-client-tls 43 | - template-haskell 44 | 45 | default-extensions: 46 | - NoImplicitPrelude 47 | - OverloadedStrings 48 | - QuasiQuotes 49 | - GeneralizedNewtypeDeriving 50 | - ConstraintKinds 51 | - FlexibleContexts 52 | - TemplateHaskell 53 | 54 | library: 55 | source-dirs: src 56 | executables: 57 | hauth-exe: 58 | main: Main.hs 59 | source-dirs: app 60 | ghc-options: 61 | - -threaded 62 | - -rtsopts 63 | - -with-rtsopts=-N 64 | dependencies: 65 | - hauth 66 | tests: 67 | hauth-test: 68 | main: Spec.hs 69 | source-dirs: test 70 | ghc-options: 71 | - -threaded 72 | - -rtsopts 73 | - -with-rtsopts=-N 74 | dependencies: 75 | - hauth 76 | - hspec 77 | - hspec-wai 78 | - hspec-wai-json 79 | - process 80 | -------------------------------------------------------------------------------- /11/src/Adapter/HTTP/API/Client/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Client.Auth where 2 | 3 | import ClassyPrelude 4 | import Network.HTTP.Client 5 | import Data.Has 6 | import qualified Domain.Auth.Types as D 7 | import Network.HTTP.Types 8 | import Adapter.HTTP.API.Types.Auth () 9 | import Adapter.HTTP.API.Client.Common 10 | import Data.Aeson 11 | 12 | register :: HttpClient r m => D.Auth -> m (Either D.RegistrationError ()) 13 | register auth = do 14 | State initReq mgr <- asks getter 15 | let req = initReq 16 | { method = "POST" 17 | , path = "/api/auth/register" 18 | , requestBody = RequestBodyLBS $ encode auth 19 | } 20 | resp <- liftIO $ httpLbs req mgr 21 | case responseStatus resp of 22 | (Status 200 _) -> 23 | return $ Right () 24 | _ -> 25 | Left <$> parseOrErr req resp 26 | 27 | verifyEmail :: HttpClient r m 28 | => D.VerificationCode -> m (Either D.EmailVerificationError ()) 29 | verifyEmail code = do 30 | State initReq mgr <- asks getter 31 | let req = initReq 32 | { method = "POST" 33 | , path = "/api/auth/verifyEmail" 34 | , requestBody = RequestBodyLBS . encode $ code 35 | } 36 | resp <- liftIO $ httpLbs req mgr 37 | case responseStatus resp of 38 | (Status 200 _) -> 39 | return $ Right () 40 | _ -> 41 | Left <$> parseOrErr req resp 42 | 43 | login :: HttpClient r m => D.Auth -> m (Either D.LoginError Session) 44 | login auth = do 45 | State initReq mgr <- asks getter 46 | let req = initReq 47 | { method = "POST" 48 | , path = "/api/auth/login" 49 | , requestBody = RequestBodyLBS $ encode auth 50 | } 51 | resp <- liftIO $ httpLbs req mgr 52 | case responseStatus resp of 53 | (Status 200 _) -> 54 | return $ Right $ responseCookieJar resp 55 | _ -> 56 | Left <$> parseOrErr req resp 57 | 58 | getUser :: HttpClient r m => Session -> m D.Email 59 | getUser session = do 60 | State initReq mgr <- asks getter 61 | let req = initReq 62 | { method = "GET" 63 | , path = "/api/users" 64 | , cookieJar = Just session 65 | } 66 | resp <- liftIO $ httpLbs req mgr 67 | case responseStatus resp of 68 | (Status 200 _) -> 69 | parseOrErr req resp 70 | _ -> 71 | throw $ UnexpectedResponse req resp -------------------------------------------------------------------------------- /11/src/Adapter/HTTP/API/Client/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Client.Common where 2 | 3 | import ClassyPrelude 4 | import Network.HTTP.Client 5 | import Network.HTTP.Client.TLS 6 | import Data.Has 7 | import Data.Aeson 8 | 9 | newtype Config = Config 10 | { configUrl :: String 11 | } 12 | 13 | data State = State 14 | { stateInitReq :: Request 15 | , stateManager :: Manager 16 | } 17 | 18 | type HttpClient r m = (MonadReader r m, Has State r, MonadIO m, MonadThrow m) 19 | 20 | type Session = CookieJar 21 | 22 | data UnexpectedResponse a = 23 | UnexpectedResponse Request (Response a) deriving (Show) 24 | 25 | instance (Typeable a, Show a) => Exception (UnexpectedResponse a) 26 | 27 | -- * Initialize 28 | 29 | withState :: Config -> (State -> IO a) -> IO a 30 | withState cfg action = do 31 | mgr <- newManager tlsManagerSettings 32 | initReq <- parseRequest $ configUrl cfg 33 | let initReqWithJson = 34 | initReq { requestHeaders = 35 | [("Content-Type", "application/json; charset=utf-8")] 36 | } 37 | action $ State initReqWithJson mgr 38 | 39 | -- * Helpers 40 | 41 | parseOrErr :: (MonadThrow m, FromJSON a) 42 | => Request -> Response LByteString -> m a 43 | parseOrErr req resp = 44 | case eitherDecode' $ responseBody resp of 45 | Left _ -> throw $ UnexpectedResponse req resp 46 | Right a -> return a -------------------------------------------------------------------------------- /11/src/Adapter/HTTP/API/Server/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Server.Auth where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Domain.Auth.Types 6 | import qualified Text.Digestive.Form as DF 7 | import Text.Digestive.Form ((.:)) 8 | import Adapter.HTTP.Common 9 | import Adapter.HTTP.API.Server.Common 10 | import Adapter.HTTP.API.Types.Auth () 11 | import Network.HTTP.Types.Status 12 | import Katip 13 | 14 | -- * Routes 15 | 16 | routes :: ( ScottyError e, MonadIO m, KatipContext m, AuthService m) 17 | => ScottyT e m () 18 | routes = do 19 | -- register 20 | post "/api/auth/register" $ do 21 | input <- parseAndValidateJSON authForm 22 | domainResult <- lift $ register input 23 | case domainResult of 24 | Left err -> do 25 | status status400 26 | json err 27 | Right _ -> 28 | return () 29 | 30 | -- verify email 31 | post "/api/auth/verifyEmail" $ do 32 | input <- parseAndValidateJSON verifyEmailForm 33 | domainResult <- lift $ verifyEmail input 34 | case domainResult of 35 | Left err -> do 36 | status status400 37 | json err 38 | Right _ -> 39 | return () 40 | 41 | -- login 42 | post "/api/auth/login" $ do 43 | input <- parseAndValidateJSON authForm 44 | domainResult <- lift $ login input 45 | case domainResult of 46 | Left err -> do 47 | status status400 48 | json err 49 | Right sId -> do 50 | setSessionIdInCookie sId 51 | return () 52 | 53 | -- get user 54 | get "/api/users" $ do 55 | userId <- reqCurrentUserId 56 | mayEmail <- lift $ getUser userId 57 | case mayEmail of 58 | Nothing -> 59 | raise $ stringError "Should not happen: SessionId map to invalid UserId" 60 | Just email -> 61 | json email 62 | 63 | -- * Forms 64 | 65 | verifyEmailForm :: (Monad m) => DF.Form [Text] m VerificationCode 66 | verifyEmailForm = DF.text Nothing 67 | 68 | authForm :: (Monad m) => DF.Form [Text] m Auth 69 | authForm = 70 | Auth <$> "email" .: emailForm 71 | <*> "password" .: passwordForm 72 | where 73 | emailForm = DF.validate (toResult . mkEmail) (DF.text Nothing) 74 | passwordForm = DF.validate (toResult . mkPassword) (DF.text Nothing) -------------------------------------------------------------------------------- /11/src/Adapter/HTTP/API/Server/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Server.Common where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Domain.Auth.Types 6 | import qualified Text.Digestive.Form as DF 7 | import qualified Text.Digestive.Aeson as DF 8 | import Data.Aeson hiding (json) 9 | import Network.HTTP.Types.Status 10 | import Adapter.HTTP.Common 11 | 12 | -- * Forms 13 | 14 | parseAndValidateJSON :: (ScottyError e, MonadIO m, ToJSON v) 15 | => DF.Form v m a -> ActionT e m a 16 | parseAndValidateJSON form = do 17 | val <- jsonData `rescue` (\_ -> return Null) 18 | validationResult <- lift $ DF.digestJSON form val 19 | case validationResult of 20 | (v, Nothing) -> do 21 | status status400 22 | json $ DF.jsonErrors v 23 | finish 24 | (_, Just result) -> 25 | return result 26 | 27 | -- * Sessions 28 | 29 | reqCurrentUserId :: (AuthService m, ScottyError e) => ActionT e m UserId 30 | reqCurrentUserId = do 31 | mayUserId <- getCurrentUserId 32 | case mayUserId of 33 | Nothing -> do 34 | status status401 35 | json ("AuthRequired" :: Text) 36 | finish 37 | Just userId -> 38 | return userId -------------------------------------------------------------------------------- /11/src/Adapter/HTTP/API/Server/Main.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Server.Main where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Network.HTTP.Types.Status 6 | import qualified Adapter.HTTP.API.Server.Auth as Auth 7 | import Domain.Auth.Types 8 | import Katip 9 | import Network.Wai 10 | import Network.Wai.Middleware.Gzip 11 | 12 | main :: ( MonadIO m, KatipContext m, AuthService m) 13 | => (m Response -> IO Response) -> IO Application 14 | main runner = 15 | scottyAppT runner routes 16 | 17 | routes :: ( MonadIO m, KatipContext m, AuthService m) 18 | => ScottyT LText m () 19 | routes = do 20 | middleware $ gzip $ def { gzipFiles = GzipCompress } 21 | 22 | Auth.routes 23 | 24 | notFound $ do 25 | status status404 26 | json ("NotFound" :: Text) 27 | 28 | defaultHandler $ \e -> do 29 | lift $ $(logTM) ErrorS $ "Unhandled error: " <> ls (showError e) 30 | status status500 31 | json ("InternalServerError" :: Text) 32 | -------------------------------------------------------------------------------- /11/src/Adapter/HTTP/API/Types/AesonHelper.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Types.AesonHelper where 2 | 3 | import ClassyPrelude 4 | import Data.Aeson.TH 5 | import Data.Aeson.Types 6 | import Language.Haskell.TH.Syntax 7 | 8 | withSmartConstructor :: (a -> Either [Text] b) -> a -> Parser b 9 | withSmartConstructor constructor a = 10 | case constructor a of 11 | Left errs -> fail $ intercalate ". " . map unpack $ errs 12 | Right val -> return val 13 | 14 | deriveJSONRecord :: Name -> Q [Dec] 15 | deriveJSONRecord record = 16 | let lowerCaseFirst (y:ys) = toLower [y] <> ys 17 | lowerCaseFirst "" = "" 18 | structName = nameBase record 19 | opts = defaultOptions 20 | { fieldLabelModifier = lowerCaseFirst . drop (length structName) 21 | } 22 | in deriveJSON opts record 23 | 24 | deriveJSONSumType :: Name -> Q [Dec] 25 | deriveJSONSumType record = 26 | let structName = nameBase record 27 | opts = defaultOptions 28 | { constructorTagModifier = drop (length structName) 29 | , tagSingleConstructors = True 30 | } 31 | in deriveJSON opts record 32 | 33 | deriveToJSONUnwrap :: Name -> Q [Dec] 34 | deriveToJSONUnwrap = 35 | let opts = defaultOptions { unwrapUnaryRecords = True } 36 | in deriveToJSON opts -------------------------------------------------------------------------------- /11/src/Adapter/HTTP/API/Types/Auth.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Adapter.HTTP.API.Types.Auth where 4 | 5 | import ClassyPrelude 6 | import Domain.Auth.Types 7 | import Data.Aeson 8 | import Adapter.HTTP.API.Types.AesonHelper 9 | 10 | instance FromJSON Email where 11 | parseJSON = 12 | withText "Email" $ withSmartConstructor mkEmail 13 | 14 | instance FromJSON Password where 15 | parseJSON = 16 | withText "Password" $ withSmartConstructor mkPassword 17 | 18 | $(map concat . sequence $ 19 | [ deriveJSONRecord ''Auth 20 | , deriveToJSONUnwrap ''Email 21 | , deriveToJSONUnwrap ''Password 22 | , deriveJSONSumType ''RegistrationError 23 | , deriveJSONSumType ''EmailVerificationError 24 | , deriveJSONSumType ''LoginError 25 | ]) -------------------------------------------------------------------------------- /11/src/Adapter/HTTP/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Common where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Blaze.ByteString.Builder (toLazyByteString) 6 | import Web.Cookie 7 | import Domain.Auth.Types 8 | import Data.Time.Lens 9 | import qualified Text.Digestive.Types as DF 10 | 11 | -- * Forms 12 | 13 | toResult :: Either e a -> DF.Result e a 14 | toResult = either DF.Error DF.Success 15 | 16 | -- * Cookies 17 | 18 | setCookie :: (ScottyError e, Monad m) => SetCookie -> ActionT e m () 19 | setCookie = setHeader "Set-Cookie" . decodeUtf8 . toLazyByteString . renderSetCookie 20 | 21 | getCookie :: (ScottyError e, Monad m) => Text -> ActionT e m (Maybe Text) 22 | getCookie key = do 23 | mCookieStr <- header "Cookie" 24 | return $ do 25 | cookie <- parseCookies . encodeUtf8 . toStrict <$> mCookieStr 26 | let bsKey = encodeUtf8 key 27 | val <- lookup bsKey cookie 28 | return $ decodeUtf8 val 29 | 30 | -- * Sessions 31 | 32 | setSessionIdInCookie :: (MonadIO m, ScottyError e) => SessionId -> ActionT e m () 33 | setSessionIdInCookie sId = do 34 | curTime <- liftIO getCurrentTime 35 | setCookie $ def { setCookieName = "sId" 36 | , setCookiePath = Just "/" 37 | , setCookieValue = encodeUtf8 sId 38 | , setCookieExpires = Just $ modL month (+ 1) curTime 39 | , setCookieHttpOnly = True 40 | , setCookieSecure = False 41 | , setCookieSameSite = Just sameSiteLax 42 | } 43 | 44 | getCurrentUserId :: (AuthService m, ScottyError e) => ActionT e m (Maybe UserId) 45 | getCurrentUserId = do 46 | maySessionId <- getCookie "sId" 47 | case maySessionId of 48 | Nothing -> return Nothing 49 | Just sId -> lift $ resolveSessionId sId -------------------------------------------------------------------------------- /11/src/Adapter/HTTP/Main.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Main where 2 | 3 | import ClassyPrelude 4 | import qualified Adapter.HTTP.API.Server.Main as API 5 | import qualified Adapter.HTTP.Web.Main as Web 6 | import Domain.Auth.Types 7 | import Katip 8 | import Network.Wai 9 | import Network.Wai.Handler.Warp 10 | import Network.Wai.Middleware.Vhost 11 | 12 | app :: (MonadIO m, KatipContext m, AuthService m) 13 | => (m Response -> IO Response) -> IO Application 14 | app runner = do 15 | web <- Web.main runner 16 | api <- API.main runner 17 | return $ vhost [(pathBeginsWith "api", api)] web 18 | where 19 | pathBeginsWith path req = headMay (pathInfo req) == Just path 20 | 21 | main :: (MonadIO m, KatipContext m, AuthService m) 22 | => Int -> (m Response -> IO Response) -> IO () 23 | main port runner = 24 | app runner >>= run port 25 | -------------------------------------------------------------------------------- /11/src/Adapter/HTTP/Web/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Web.Common where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Domain.Auth.Types 6 | import qualified Text.Digestive.View as DF 7 | import Text.Blaze.Html5 ((!)) 8 | import qualified Text.Blaze.Html5 as H 9 | import qualified Text.Blaze.Html5.Attributes as A 10 | import qualified Text.Blaze.Html.Renderer.Text as H 11 | import Adapter.HTTP.Common 12 | 13 | -- * Views 14 | 15 | renderHtml :: (ScottyError e, Monad m) => H.Html -> ActionT e m () 16 | renderHtml = html . H.renderHtml 17 | 18 | mainLayout :: Text -> H.Html -> H.Html 19 | mainLayout title content = 20 | H.docTypeHtml $ do 21 | H.head $ do 22 | favicon "/images/logo.png" 23 | H.title $ H.toHtml title 24 | H.body $ do 25 | H.div $ H.img ! A.src "/images/logo.png" 26 | H.div content 27 | where 28 | favicon path = 29 | H.link ! A.rel "icon" 30 | ! A.type_ "image/png" 31 | ! A.href path 32 | 33 | formLayout :: DF.View a -> Text -> H.Html -> H.Html 34 | formLayout view action = 35 | H.form ! A.method "POST" 36 | ! A.enctype (H.toValue $ show $ DF.viewEncType view) 37 | ! A.action (H.toValue action) 38 | 39 | -- * Sessions 40 | 41 | reqCurrentUserId :: (AuthService m, ScottyError e) => ActionT e m UserId 42 | reqCurrentUserId = do 43 | mUserId <- getCurrentUserId 44 | case mUserId of 45 | Nothing -> 46 | redirect "/auth/login" 47 | Just userId -> 48 | return userId -------------------------------------------------------------------------------- /11/src/Adapter/HTTP/Web/Main.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Web.Main where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Network.HTTP.Types.Status 6 | import qualified Adapter.HTTP.Web.Auth as Auth 7 | import Domain.Auth.Types 8 | import Katip 9 | import Network.Wai 10 | import Network.Wai.Middleware.Static 11 | import Network.Wai.Middleware.Gzip 12 | 13 | main :: ( MonadIO m, KatipContext m, AuthService m) 14 | => (m Response -> IO Response) -> IO Application 15 | main runner = do 16 | cacheContainer <- initCaching PublicStaticCaching 17 | scottyAppT runner $ routes cacheContainer 18 | 19 | routes :: ( MonadIO m, KatipContext m, AuthService m) 20 | => CacheContainer -> ScottyT LText m () 21 | routes cacheContainer = do 22 | middleware $ 23 | gzip $ def { gzipFiles = GzipCompress } 24 | middleware $ 25 | staticPolicy' cacheContainer (addBase "src/Adapter/HTTP/Web/static") 26 | 27 | Auth.routes 28 | 29 | notFound $ do 30 | status status404 31 | text "Not found" 32 | 33 | defaultHandler $ \e -> do 34 | lift $ $(logTM) ErrorS $ "Unhandled error: " <> ls (showError e) 35 | status status500 36 | text "Internal server error!" 37 | -------------------------------------------------------------------------------- /11/src/Adapter/HTTP/Web/static/images/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-webdev-haskell/17b90c06030def254bb0497b9e357f5d3b96d0cf/11/src/Adapter/HTTP/Web/static/images/logo.png -------------------------------------------------------------------------------- /11/src/Adapter/PostgreSQL/Migrations/00000_auths.sql: -------------------------------------------------------------------------------- 1 | create extension citext; 2 | create extension pgcrypto; 3 | 4 | create table auths ( 5 | id bigserial primary key not null, 6 | pass text not null, 7 | email citext not null unique, 8 | email_verification_code text not null, 9 | is_email_verified boolean not null 10 | ); -------------------------------------------------------------------------------- /11/src/Adapter/RabbitMQ/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.RabbitMQ.Auth where 2 | 3 | import ClassyPrelude 4 | import Adapter.RabbitMQ.Common 5 | import Network.AMQP 6 | import Katip 7 | import Data.Aeson 8 | import Data.Aeson.TH 9 | import qualified Domain.Auth.Types as D 10 | 11 | data EmailVerificationPayload = EmailVerificationPayload 12 | { emailVerificationPayloadEmail :: Text 13 | , emailVerificationPayloadVerificationCode :: Text 14 | } 15 | 16 | 17 | class (Monad m) => EmailVerificationSender m where 18 | sendEmailVerification :: D.Email -> D.VerificationCode -> m () 19 | 20 | 21 | init :: (EmailVerificationSender m, KatipContext m, MonadCatch m) 22 | => State -> (m Bool -> IO Bool) -> IO () 23 | init state runner = do 24 | initQueue state "verifyEmail" "auth" "userRegistered" 25 | initConsumer state "verifyEmail" (consumeEmailVerification runner) 26 | 27 | consumeEmailVerification :: (EmailVerificationSender m, KatipContext m, MonadCatch m) 28 | => (m Bool -> IO Bool) -> Message -> IO Bool 29 | consumeEmailVerification runner msg = 30 | runner $ consumeAndProcess msg handler 31 | where 32 | handler payload = 33 | case D.mkEmail (emailVerificationPayloadEmail payload) of 34 | Left err -> withMsgAndErr msg err $ do 35 | $(logTM) ErrorS "Email format is invalid. Rejecting." 36 | return False 37 | Right email -> do 38 | let vCode = emailVerificationPayloadVerificationCode payload 39 | sendEmailVerification email vCode 40 | return True 41 | 42 | notifyEmailVerification :: (Rabbit r m) => D.Email -> D.VerificationCode -> m () 43 | notifyEmailVerification email vCode = 44 | let payload = EmailVerificationPayload (D.rawEmail email) vCode 45 | in publish "auth" "userRegistered" payload 46 | 47 | -- JSON serde 48 | 49 | $(let structName = fromMaybe "" . lastMay . splitElem '.' . show $ ''EmailVerificationPayload 50 | lowercaseFirst (x:xs) = toLower [x] <> xs 51 | lowercaseFirst xs = xs 52 | options = defaultOptions 53 | { fieldLabelModifier = lowercaseFirst . drop (length structName) 54 | } 55 | in deriveJSON options ''EmailVerificationPayload) -------------------------------------------------------------------------------- /11/src/Adapter/Redis/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Redis.Auth where 2 | 3 | import ClassyPrelude 4 | import qualified Domain.Auth.Types as D 5 | import Text.StringRandom 6 | import Data.Has 7 | import qualified Database.Redis as R 8 | 9 | type State = R.Connection 10 | 11 | type Redis r m = (Has State r, MonadReader r m, MonadIO m, MonadThrow m) 12 | 13 | -- | Create state from redis url string. 14 | -- format: redis://user:pass@host:port/db 15 | -- sample: redis://abc:def@localhost:6379/0 16 | withState :: String -> (State -> IO a) -> IO a 17 | withState connUrl action = 18 | case R.parseConnectInfo connUrl of 19 | Left _ -> 20 | throwString $ "Invalid Redis conn URL: " <> connUrl 21 | Right connInfo -> do 22 | conn <- R.checkedConnect connInfo 23 | action conn 24 | 25 | withConn :: Redis r m => R.Redis a -> m a 26 | withConn action = do 27 | conn <- asks getter 28 | liftIO $ R.runRedis conn action 29 | 30 | newSession :: Redis r m => D.UserId -> m D.SessionId 31 | newSession userId = do 32 | sId <- liftIO $ stringRandomIO "[a-zA-Z0-9]{32}" 33 | result <- withConn $ R.set (encodeUtf8 sId) (fromString . show $ userId) 34 | case result of 35 | Right R.Ok -> return sId 36 | err -> throwString $ "Unexpected redis error: " <> show err 37 | 38 | findUserIdBySessionId :: Redis r m => D.SessionId -> m (Maybe D.UserId) 39 | findUserIdBySessionId sId = do 40 | result <- withConn $ R.get (encodeUtf8 sId) 41 | return $ case result of 42 | Right (Just uIdStr) -> readMay . unpack . decodeUtf8 $ uIdStr 43 | err -> throwString $ "Unexpected redis error: " <> show err 44 | -------------------------------------------------------------------------------- /11/src/Config.hs: -------------------------------------------------------------------------------- 1 | module Config where 2 | 3 | import ClassyPrelude 4 | import System.Environment 5 | import qualified Adapter.PostgreSQL.Auth as PG 6 | import qualified Adapter.RabbitMQ.Common as MQ 7 | 8 | data Config = Config 9 | { configPort :: Int 10 | , configRedis :: String 11 | , configMQ :: MQ.Config 12 | , configPG :: PG.Config 13 | } deriving (Eq, Show) 14 | 15 | fromEnv :: IO Config 16 | fromEnv = Config 17 | <$> envRead "PORT" 18 | <*> getEnv "REDIS_URL" 19 | <*> (MQ.Config 20 | <$> getEnv "MQ_URL" 21 | <*> pure 16 22 | ) 23 | <*> (PG.Config 24 | <$> envFromString "PG_URL" 25 | <*> pure 2 26 | <*> pure 5 27 | <*> pure 10 28 | ) 29 | 30 | devConfig :: Config 31 | devConfig = Config 32 | { configPort = 3000 33 | , configRedis = "redis://localhost:6379/0" 34 | , configMQ = MQ.Config 35 | { MQ.configUrl = "amqp://guest:guest@localhost:5672/%2F" 36 | , MQ.configPrefetchCount = 16 37 | } 38 | , configPG = PG.Config 39 | { PG.configUrl = "postgresql://localhost/hauth" 40 | , PG.configStripeCount = 2 41 | , PG.configMaxOpenConnPerStripe = 5 42 | , PG.configIdleConnTimeout = 10 43 | } 44 | } 45 | 46 | -- * Helpers 47 | 48 | envFromString :: (IsString a) => String -> IO a 49 | envFromString key = fromString <$> getEnv key 50 | 51 | envRead :: Read a => String -> IO a 52 | envRead key = do 53 | rawVal <- getEnv key 54 | case readMay rawVal of 55 | Just val -> return val 56 | Nothing -> throwString $ key <> ": Unable to parse " <> rawVal 57 | -------------------------------------------------------------------------------- /11/src/Domain/Auth/Service.hs: -------------------------------------------------------------------------------- 1 | module Domain.Auth.Service where 2 | 3 | import ClassyPrelude 4 | import Domain.Auth.Types 5 | import Control.Monad.Except 6 | import Katip 7 | 8 | class (Monad m) => AuthRepo m where 9 | addAuth :: Auth -> m (Either RegistrationError (UserId, VerificationCode)) 10 | setEmailAsVerified :: VerificationCode 11 | -> m (Either EmailVerificationError (UserId, Email)) 12 | findUserByAuth :: Auth -> m (Maybe (UserId, Bool)) 13 | findEmailFromUserId :: UserId -> m (Maybe Email) 14 | 15 | class (Monad m) => EmailVerificationNotif m where 16 | notifyEmailVerification :: Email -> VerificationCode -> m () 17 | 18 | class (Monad m) => SessionRepo m where 19 | newSession :: UserId -> m SessionId 20 | findUserIdBySessionId :: SessionId -> m (Maybe UserId) 21 | 22 | 23 | withUserIdContext :: (KatipContext m) => UserId -> m a -> m a 24 | withUserIdContext uId = katipAddContext (sl "userId" uId) 25 | 26 | register :: (KatipContext m, AuthRepo m, EmailVerificationNotif m) 27 | => Auth -> m (Either RegistrationError ()) 28 | register auth = runExceptT $ do 29 | (uId, vCode) <- ExceptT $ addAuth auth 30 | let email = authEmail auth 31 | lift $ notifyEmailVerification email vCode 32 | withUserIdContext uId $ 33 | $(logTM) InfoS $ ls (rawEmail email) <> " is registered successfully" 34 | 35 | verifyEmail :: (KatipContext m, AuthRepo m) 36 | => VerificationCode -> m (Either EmailVerificationError ()) 37 | verifyEmail vCode = runExceptT $ do 38 | (uId, email) <- ExceptT $ setEmailAsVerified vCode 39 | withUserIdContext uId $ 40 | $(logTM) InfoS $ ls (rawEmail email) <> " is verified successfully" 41 | return () 42 | 43 | login :: (KatipContext m, AuthRepo m, SessionRepo m) 44 | => Auth -> m (Either LoginError SessionId) 45 | login auth = runExceptT $ do 46 | result <- lift $ findUserByAuth auth 47 | case result of 48 | Nothing -> throwError LoginErrorInvalidAuth 49 | Just (_, False) -> throwError LoginErrorEmailNotVerified 50 | Just (uId, _) -> withUserIdContext uId . lift $ do 51 | sId <- newSession uId 52 | $(logTM) InfoS $ ls (rawEmail $ authEmail auth) <> " logged in successfully" 53 | return sId 54 | 55 | resolveSessionId :: (SessionRepo m) => SessionId -> m (Maybe UserId) 56 | resolveSessionId = findUserIdBySessionId 57 | 58 | getUser :: (AuthRepo m) => UserId -> m (Maybe Email) 59 | getUser = findEmailFromUserId 60 | -------------------------------------------------------------------------------- /11/src/Domain/Auth/Types.hs: -------------------------------------------------------------------------------- 1 | module Domain.Auth.Types ( 2 | -- * Types 3 | Auth(..), 4 | Email(rawEmail), 5 | mkEmail, 6 | Password(rawPassword), 7 | mkPassword, 8 | UserId, 9 | VerificationCode, 10 | SessionId, 11 | RegistrationError(..), 12 | EmailVerificationError(..), 13 | LoginError(..), 14 | 15 | -- * Services 16 | AuthService(..) 17 | ) where 18 | 19 | import ClassyPrelude 20 | import Domain.Validation 21 | import Text.Regex.PCRE.Heavy 22 | 23 | newtype Email = Email { rawEmail :: Text } deriving (Show, Eq, Ord) 24 | 25 | mkEmail :: Text -> Either [ErrMsg] Email 26 | mkEmail = 27 | validate Email 28 | [ regexMatches 29 | [re|^[A-Z0-9a-z._%+-]+@[A-Za-z0-9.-]+\.[A-Za-z]{2,64}$|] 30 | "Not a valid email" 31 | ] 32 | 33 | newtype Password = Password { rawPassword :: Text } deriving (Show, Eq) 34 | 35 | mkPassword :: Text -> Either [ErrMsg] Password 36 | mkPassword = 37 | validate Password 38 | [ lengthBetween 5 50 "Should between 5 and 50" 39 | , regexMatches [re|\d|] "Should contain number" 40 | , regexMatches [re|[A-Z]|] "Should contain uppercase letter" 41 | , regexMatches [re|[a-z]|] "Should contain lowercase letter" 42 | ] 43 | 44 | data Auth = Auth 45 | { authEmail :: Email 46 | , authPassword :: Password 47 | } deriving (Show, Eq) 48 | 49 | type UserId = Int 50 | 51 | type VerificationCode = Text 52 | 53 | type SessionId = Text 54 | 55 | data RegistrationError 56 | = RegistrationErrorEmailTaken 57 | deriving (Show, Eq) 58 | 59 | data EmailVerificationError 60 | = EmailVerificationErrorInvalidCode 61 | deriving (Show, Eq) 62 | 63 | data LoginError 64 | = LoginErrorInvalidAuth 65 | | LoginErrorEmailNotVerified 66 | deriving (Show, Eq) 67 | 68 | 69 | class (Monad m) => AuthService m where 70 | register :: Auth -> m (Either RegistrationError ()) 71 | verifyEmail :: VerificationCode -> m (Either EmailVerificationError ()) 72 | login :: Auth -> m (Either LoginError SessionId) 73 | resolveSessionId :: SessionId -> m (Maybe UserId) 74 | getUser :: UserId -> m (Maybe Email) 75 | -------------------------------------------------------------------------------- /11/src/Domain/Validation.hs: -------------------------------------------------------------------------------- 1 | module Domain.Validation where 2 | 3 | import ClassyPrelude 4 | import Text.Regex.PCRE.Heavy 5 | 6 | type ErrMsg = Text 7 | type Validation a = a -> Maybe ErrMsg 8 | 9 | validate :: (a -> b) -> [Validation a] -> a -> Either [ErrMsg] b 10 | validate constructor validations val = 11 | case concatMap (\f -> maybeToList $ f val) validations of 12 | [] -> Right $ constructor val 13 | errs -> Left errs 14 | 15 | rangeBetween :: (Ord a) => a -> a -> ErrMsg -> Validation a 16 | rangeBetween minRange maxRange msg val = 17 | if val >= minRange && val <= maxRange then Nothing else Just msg 18 | 19 | lengthBetween :: (MonoFoldable a) => Int -> Int -> ErrMsg -> Validation a 20 | lengthBetween minLen maxLen msg val = 21 | rangeBetween minLen maxLen msg (length val) 22 | 23 | regexMatches :: Regex -> ErrMsg -> Validation Text 24 | regexMatches regex msg val = 25 | if val =~ regex then Nothing else Just msg 26 | -------------------------------------------------------------------------------- /11/test/Adapter/HTTP/Fixture.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Fixture where 2 | 3 | import ClassyPrelude 4 | import Domain.Auth.Types 5 | import Katip 6 | import Network.Wai 7 | import qualified Adapter.HTTP.Main as HTTP 8 | import Fixture 9 | 10 | data Fixture m = Fixture 11 | { _register :: Auth -> m (Either RegistrationError ()) 12 | , _verifyEmail :: VerificationCode -> m (Either EmailVerificationError ()) 13 | , _login :: Auth -> m (Either LoginError SessionId) 14 | , _resolveSessionId :: SessionId -> m (Maybe UserId) 15 | , _getUser :: UserId -> m (Maybe Email) 16 | } 17 | 18 | emptyFixture :: Fixture IO 19 | emptyFixture = Fixture 20 | { _register = const unimplemented 21 | , _verifyEmail = const unimplemented 22 | , _login = const unimplemented 23 | , _resolveSessionId = const unimplemented 24 | , _getUser = const unimplemented 25 | } 26 | 27 | newtype App a = App 28 | { unApp :: ReaderT (Fixture IO) (KatipContextT IO) a 29 | } deriving ( Applicative, Functor, Monad, MonadReader (Fixture IO), MonadIO 30 | , KatipContext, Katip 31 | ) 32 | 33 | app :: Fixture IO -> IO Application 34 | app fixture = do 35 | le <- initLogEnv "HAuth" "test" 36 | let runner = runKatipContextT le () mempty . flip runReaderT fixture . unApp 37 | HTTP.app runner 38 | 39 | instance AuthService App where 40 | register = dispatch _register 41 | verifyEmail = dispatch _verifyEmail 42 | login = dispatch _login 43 | resolveSessionId = dispatch _resolveSessionId 44 | getUser = dispatch _getUser -------------------------------------------------------------------------------- /11/test/Adapter/Redis/AuthSpec.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Redis.AuthSpec where 2 | 3 | import ClassyPrelude 4 | import Test.Hspec 5 | import qualified Database.Redis as R 6 | import Adapter.Redis.Auth 7 | 8 | spec :: Spec 9 | spec = beforeAll initDB $ 10 | describe "findUserIdBySessionId" $ do 11 | it "should return Nothing if session is invalid" $ 12 | runTestApp (findUserIdBySessionId "invalidSession") 13 | `shouldReturn` Nothing 14 | it "should return valid user id if session is valid" $ do 15 | let uId = 1 16 | runTestApp (newSession uId >>= findUserIdBySessionId) 17 | `shouldReturn` Just uId 18 | 19 | initDB :: IO () 20 | initDB = do 21 | let connInfo = either (error "Invalid Redis conn URL") id 22 | $ R.parseConnectInfo testConf 23 | conn <- R.checkedConnect connInfo 24 | void $ R.runRedis conn R.flushdb 25 | 26 | testConf :: String 27 | testConf = "redis://localhost:6379/8" 28 | 29 | runTestApp :: ReaderT State IO a -> IO a 30 | runTestApp action = 31 | withState testConf $ runReaderT action -------------------------------------------------------------------------------- /11/test/ConfigSpec.hs: -------------------------------------------------------------------------------- 1 | module ConfigSpec where 2 | 3 | import ClassyPrelude 4 | import Test.Hspec 5 | import System.Environment 6 | import Config 7 | import qualified Adapter.PostgreSQL.Auth as PG 8 | import qualified Adapter.RabbitMQ.Common as MQ 9 | 10 | spec :: Spec 11 | spec = before initEnv $ do 12 | it "should fail if PORT is missing" $ do 13 | unsetEnv "PORT" 14 | void fromEnv `shouldThrow` anyException 15 | it "should fail if PORT is not a number" $ do 16 | setEnv "PORT" "NOT A NUMBER" 17 | void fromEnv `shouldThrow` anyException 18 | it "should fail if REDIS_URL is missing" $ do 19 | unsetEnv "REDIS_URL" 20 | void fromEnv `shouldThrow` anyException 21 | it "should fail if MQ_URL is missing" $ do 22 | unsetEnv "MQ_URL" 23 | void fromEnv `shouldThrow` anyException 24 | it "should fail if PG_URL is missing" $ do 25 | unsetEnv "PG_URL" 26 | void fromEnv `shouldThrow` anyException 27 | it "should parse config correctly" $ 28 | fromEnv `shouldReturn` Config 29 | { configPort = 1234 30 | , configRedis = "REDIS_URL" 31 | , configMQ = MQ.Config "MQ_URL" 16 32 | , configPG = PG.Config "PG_URL" 2 5 10 33 | } 34 | 35 | initEnv :: IO () 36 | initEnv = do 37 | setEnv "PORT" "1234" 38 | setEnv "REDIS_URL" "REDIS_URL" 39 | setEnv "MQ_URL" "MQ_URL" 40 | setEnv "PG_URL" "PG_URL" -------------------------------------------------------------------------------- /11/test/Domain/Auth/TypesSpec.hs: -------------------------------------------------------------------------------- 1 | module Domain.Auth.TypesSpec where 2 | 3 | import ClassyPrelude 4 | import Test.Hspec 5 | import Domain.Auth.Types 6 | 7 | spec :: Spec 8 | spec = do 9 | describe "mkEmail" $ do 10 | describe "should pass" $ 11 | mkEmailSpec "ecky@test.com" True 12 | describe "should fail" $ do 13 | mkEmailSpec "invalid email@test.com" False 14 | mkEmailSpec "email@test." False 15 | mkEmailSpec "test.com" False 16 | 17 | describe "mkPassword" $ do 18 | describe "should pass" $ 19 | mkPasswordSpec "abcDEF123" [] 20 | describe "should fail" $ do 21 | mkPasswordSpec "aA1" ["Should between 5 and 50"] 22 | mkPasswordSpec (fromString . take 51 . join $ repeat "aA1") ["Should between 5 and 50"] 23 | mkPasswordSpec "abcDEF" ["Should contain number"] 24 | mkPasswordSpec "abc123" ["Should contain uppercase letter"] 25 | mkPasswordSpec "ABC123" ["Should contain lowercase letter"] 26 | 27 | mkEmailSpec :: Text -> Bool -> Spec 28 | mkEmailSpec email isValid = 29 | it (unpack email) $ 30 | case (isValid, mkEmail email) of 31 | (True, result) -> 32 | result `shouldSatisfy` either (const False) ((email ==) . rawEmail) 33 | (False, result) -> 34 | result `shouldSatisfy` either (["Not a valid email"] ==) (const False) 35 | 36 | mkPasswordSpec :: Text -> [Text] -> Spec 37 | mkPasswordSpec password errMsgs = 38 | it (unpack password) $ 39 | case (errMsgs, mkPassword password) of 40 | ([], result) -> 41 | result `shouldSatisfy` either (const False) ((password ==) . rawPassword) 42 | (msgs, result) -> 43 | result `shouldSatisfy` either (msgs ==) (const False) -------------------------------------------------------------------------------- /11/test/Domain/ValidationSpec.hs: -------------------------------------------------------------------------------- 1 | module Domain.ValidationSpec where 2 | 3 | import ClassyPrelude 4 | import Test.Hspec 5 | import Domain.Validation 6 | import Text.Regex.PCRE.Heavy 7 | 8 | spec :: Spec 9 | spec = do 10 | describe "rangeBetween" $ do 11 | let validator = rangeBetween 1 10 "fail" 12 | it "val < min should fail" $ 13 | validator 0 `shouldBe` Just "fail" 14 | it "val == min should pass" $ 15 | validator 1 `shouldBe` Nothing 16 | it "min < val < max should pass" $ 17 | validator 5 `shouldBe` Nothing 18 | it "val == max should pass" $ 19 | validator 10 `shouldBe` Nothing 20 | it "val > max should fail" $ 21 | validator 11 `shouldBe` Just "fail" 22 | 23 | describe "lengthBetween" $ do 24 | let validator = lengthBetween 1 10 "fail" 25 | it "val < min should fail" $ 26 | validator [] `shouldBe` Just "fail" 27 | it "val == min should pass" $ 28 | validator [1] `shouldBe` Nothing 29 | it "min < val < max should pass" $ 30 | validator [1..5] `shouldBe` Nothing 31 | it "val == max should pass" $ 32 | validator [1..10] `shouldBe` Nothing 33 | it "val > max should fail" $ 34 | validator [1..11] `shouldBe` Just "fail" 35 | 36 | describe "regexMatches" $ do 37 | let validator = regexMatches [re|^hello|] "fail" 38 | it "if matches found then it should pass" $ 39 | validator "hello world" `shouldBe` Nothing 40 | it "if no match found then it should fail" $ 41 | validator "world hello" `shouldBe` Just "fail" -------------------------------------------------------------------------------- /11/test/Fixture.hs: -------------------------------------------------------------------------------- 1 | module Fixture where 2 | 3 | import ClassyPrelude 4 | 5 | unimplemented :: a 6 | unimplemented = error "unimplemented" 7 | 8 | dispatch :: (MonadIO m, MonadReader r m) 9 | => (r -> a -> IO b) 10 | -> (a -> m b) 11 | dispatch getter param = do 12 | func <- asks getter 13 | liftIO $ func param 14 | 15 | dispatch2 :: (MonadIO m, MonadReader r m) 16 | => (r -> a -> b -> IO c) 17 | -> (a -> b -> m c) 18 | dispatch2 getter param1 param2 = do 19 | func <- asks getter 20 | liftIO $ func param1 param2 21 | -------------------------------------------------------------------------------- /11/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} -------------------------------------------------------------------------------- /12/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | .hspec-failures 3 | *.tix 4 | .DS_Store 5 | *.cabal 6 | dist 7 | report.html 8 | weeder.txt 9 | hpc-threshold.txt -------------------------------------------------------------------------------- /12/.hlint.yaml: -------------------------------------------------------------------------------- 1 | # HLint configuration file 2 | # https://github.com/ndmitchell/hlint 3 | ########################## 4 | 5 | # This file contains a template configuration file, which is typically 6 | # placed as .hlint.yaml in the root of your project 7 | 8 | 9 | # Warnings currently triggered by your code 10 | - ignore: {name: "Parse error"} 11 | 12 | 13 | # Specify additional command line arguments 14 | # 15 | # - arguments: [--color, --cpp-simple, -XQuasiQuotes] 16 | 17 | 18 | # Control which extensions/flags/modules/functions can be used 19 | # 20 | # - extensions: 21 | # - default: false # all extension are banned by default 22 | # - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used 23 | # - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module 24 | # 25 | # - flags: 26 | # - {name: -w, within: []} # -w is allowed nowhere 27 | # 28 | # - modules: 29 | # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' 30 | # - {name: Control.Arrow, within: []} # Certain modules are banned entirely 31 | # 32 | # - functions: 33 | # - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules 34 | 35 | 36 | # Add custom hints for this project 37 | # 38 | # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" 39 | # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} 40 | 41 | 42 | # Turn on hints that are off by default 43 | # 44 | # Ban "module X(module X) where", to require a real export list 45 | # - warn: {name: Use explicit module export list} 46 | # 47 | # Replace a $ b $ c with a . b $ c 48 | # - group: {name: dollar, enabled: true} 49 | # 50 | # Generalise map to fmap, ++ to <> 51 | # - group: {name: generalise, enabled: true} 52 | 53 | 54 | # Ignore some builtin hints 55 | # - ignore: {name: Use let} 56 | # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules 57 | 58 | 59 | # Define some custom infix operators 60 | # - fixity: infixr 3 ~^#^~ 61 | 62 | 63 | # To generate a suitable file for HLint do: 64 | # $ hlint --default > .hlint.yaml 65 | -------------------------------------------------------------------------------- /12/.hpc-threshold: -------------------------------------------------------------------------------- 1 | [ Threshold 2 | { thresholdName = "Expressions used" 3 | , thresholdRegex = "(\\d+)% expressions used" 4 | , thresholdValue = 45.0 5 | } 6 | , Threshold 7 | { thresholdName = "Boolean coverage" 8 | , thresholdRegex = "(\\d+)% boolean coverage" 9 | , thresholdValue = 15.0 10 | } 11 | , Threshold 12 | { thresholdName = "Alternatives used" 13 | , thresholdRegex = "(\\d+)% alternatives used" 14 | , thresholdValue = 45.0 15 | } 16 | , Threshold 17 | { thresholdName = "Local declarations used" 18 | , thresholdRegex = "(\\d+)% local declarations used" 19 | , thresholdValue = 65.0 20 | } 21 | , Threshold 22 | { thresholdName = "Top-level declarations used" 23 | , thresholdRegex = "(\\d+)% top-level declarations used" 24 | , thresholdValue = 45.0 25 | } 26 | ] 27 | -------------------------------------------------------------------------------- /12/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 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 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /12/README.md: -------------------------------------------------------------------------------- 1 | # hauth 2 | 3 | ## Building, Testing, and Running Static Analysis Tools 4 | 5 | To build the application: 6 | 7 | ``` 8 | $ ./build.sh 9 | ``` 10 | 11 | The result of the build is produced in `dist` folder. 12 | 13 | ## Building a Docker Image Of The Applicaiton 14 | 15 | ``` 16 | $ ./scripts/build-docker 17 | ``` 18 | 19 | The resulting image is tagged with `eckyputrady/hauth:latest`. 20 | -------------------------------------------------------------------------------- /12/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /12/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Lib 4 | 5 | main :: IO () 6 | main = Lib.main 7 | -------------------------------------------------------------------------------- /12/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e # makes the script fail if any one of the below operation fails 3 | 4 | ### prepare distribution folders 5 | 6 | rm -rf dist 7 | mkdir dist 8 | 9 | ### build & test 10 | 11 | echo "Build & test" 12 | stack build --test --coverage 13 | echo "Build & test finished with exit code $?" 14 | cp -r $(stack path --local-install-root)/bin dist/bin 15 | 16 | ### copy non-hs resources 17 | 18 | cp -r app dist/app 19 | cp -r src dist/src 20 | cd dist 21 | find . -name "*.hs" -type f -delete 22 | find . -type d -empty -delete 23 | cd .. 24 | 25 | ### code quality tools 26 | 27 | echo "Installing code quality tools" 28 | stack install hlint weeder hpc-threshold 29 | 30 | echo "Running HLint ..." 31 | hlint . 32 | echo "HLint finished with exit code $?" 33 | 34 | echo "Running Weeder ..." 35 | weeder . 36 | echo "Weeder finished with exit code $?" 37 | 38 | echo "Running hpc-threshold ..." 39 | (stack hpc report --all 2>&1) | hpc-threshold 40 | echo "hpc-threshold finished with exit code $?" 41 | 42 | ### report 43 | 44 | echo "Build finished. see /dist." -------------------------------------------------------------------------------- /12/package.yaml: -------------------------------------------------------------------------------- 1 | name: hauth 2 | version: '0.1.0.0' 3 | category: Web 4 | author: Ecky Putrady 5 | maintainer: eckyp@example.com 6 | copyright: 2017 Ecky Putrady 7 | license: BSD3 8 | github: githubuser/hauth 9 | extra-source-files: 10 | - README.md 11 | 12 | default-extensions: 13 | - OverloadedStrings 14 | - QuasiQuotes 15 | - GeneralizedNewtypeDeriving 16 | - ConstraintKinds 17 | - FlexibleContexts 18 | - TemplateHaskell 19 | - LambdaCase 20 | 21 | ghc-options: 22 | - -Wall 23 | - -Werror 24 | - -Wincomplete-record-updates 25 | - -Wincomplete-uni-patterns 26 | - -Wredundant-constraints 27 | 28 | library: 29 | source-dirs: src 30 | default-extensions: 31 | - NoImplicitPrelude 32 | dependencies: 33 | - classy-prelude 34 | - base 35 | - pcre-heavy 36 | - time-lens 37 | - time 38 | - aeson 39 | - mtl 40 | - string-random 41 | - data-has 42 | - katip 43 | - postgresql-simple 44 | - postgresql-simple-migration 45 | - resource-pool 46 | - hedis 47 | - amqp 48 | - http-types 49 | - scotty 50 | - cookie 51 | - wai 52 | - wai-extra 53 | - blaze-builder 54 | - digestive-functors 55 | - digestive-functors-aeson 56 | - blaze-html 57 | - digestive-functors-blaze 58 | - digestive-functors-scotty 59 | - wai-middleware-static 60 | - warp 61 | - http-client 62 | - http-client-tls 63 | - template-haskell 64 | executables: 65 | hauth-exe: 66 | main: Main.hs 67 | source-dirs: app 68 | ghc-options: 69 | - -threaded 70 | - -rtsopts 71 | - -with-rtsopts=-N 72 | dependencies: 73 | - hauth 74 | - base 75 | tests: 76 | hauth-test: 77 | main: Spec.hs 78 | source-dirs: test 79 | ghc-options: 80 | - -threaded 81 | - -rtsopts 82 | - -with-rtsopts=-N 83 | default-extensions: 84 | - NoImplicitPrelude 85 | dependencies: 86 | - classy-prelude 87 | - base 88 | - hauth 89 | - hspec 90 | - hspec-wai 91 | - hspec-wai-json 92 | - process 93 | - postgresql-simple 94 | - string-random 95 | - hedis 96 | - pcre-heavy 97 | - katip 98 | - http-types 99 | - wai 100 | -------------------------------------------------------------------------------- /12/scripts/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM eckyputrady/haskell-run:lts-10.3 2 | 3 | COPY ["./dist", "/dist"] 4 | 5 | ENTRYPOINT respawn ./bin/hauth-exe -------------------------------------------------------------------------------- /12/scripts/build-docker.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | docker run \ 3 | -v ~/.stack:/root/.stack \ 4 | -v $(pwd):/root/work \ 5 | eckyputrady/haskell-build-web:lts-10.3 6 | 7 | cd scripts 8 | cp -r ../dist ./dist 9 | docker build -f scripts/Dockerfile -t eckyputrady/hauth:latest . 10 | rm -rf ./dist -------------------------------------------------------------------------------- /12/scripts/docker-compose.yml: -------------------------------------------------------------------------------- 1 | version: "3.3" 2 | services: 3 | hauth: 4 | image: eckyputrady/hauth:latest 5 | environment: 6 | - PORT=3000 7 | - PG_URL=postgresql://hauth:hauthpass@postgres:5432/hauth 8 | - MQ_URL=amqp://hauth:hauthpass@rabbitmq:5672/%2F 9 | - REDIS_URL=redis://redis:6379/0 10 | depends_on: 11 | - postgres 12 | - redis 13 | - rabbitmq 14 | ports: 15 | - "80:3000" 16 | 17 | postgres: 18 | image: postgres:9.6 19 | environment: 20 | - POSTGRES_PASSWORD=hauthpass 21 | - POSTGRES_USER=hauth 22 | - POSTGRES_DB=hauth 23 | ports: 24 | - "5432:5432" 25 | 26 | redis: 27 | image: redis:4 28 | ports: 29 | - "6379:6379" 30 | 31 | rabbitmq: 32 | image: rabbitmq:3-management 33 | hostname: rabbitmq 34 | ports: 35 | - "15672:15672" 36 | environment: 37 | - RABBITMQ_DEFAULT_USER=hauth 38 | - RABBITMQ_DEFAULT_PASS=hauthpass 39 | 40 | -------------------------------------------------------------------------------- /12/src/Adapter/HTTP/API/Client/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Client.Auth where 2 | 3 | import ClassyPrelude 4 | import Network.HTTP.Client 5 | import Data.Has 6 | import qualified Domain.Auth.Types as D 7 | import Network.HTTP.Types 8 | import Adapter.HTTP.API.Types.Auth () 9 | import Adapter.HTTP.API.Client.Common 10 | import Data.Aeson 11 | 12 | register :: HttpClient r m => D.Auth -> m (Either D.RegistrationError ()) 13 | register auth = do 14 | State initReq mgr <- asks getter 15 | let req = initReq 16 | { method = "POST" 17 | , path = "/api/auth/register" 18 | , requestBody = RequestBodyLBS $ encode auth 19 | } 20 | resp <- liftIO $ httpLbs req mgr 21 | case responseStatus resp of 22 | (Status 200 _) -> 23 | return $ Right () 24 | _ -> 25 | Left <$> parseOrErr req resp 26 | 27 | verifyEmail :: HttpClient r m 28 | => D.VerificationCode -> m (Either D.EmailVerificationError ()) 29 | verifyEmail code = do 30 | State initReq mgr <- asks getter 31 | let req = initReq 32 | { method = "POST" 33 | , path = "/api/auth/verifyEmail" 34 | , requestBody = RequestBodyLBS . encode $ code 35 | } 36 | resp <- liftIO $ httpLbs req mgr 37 | case responseStatus resp of 38 | (Status 200 _) -> 39 | return $ Right () 40 | _ -> 41 | Left <$> parseOrErr req resp 42 | 43 | login :: HttpClient r m => D.Auth -> m (Either D.LoginError Session) 44 | login auth = do 45 | State initReq mgr <- asks getter 46 | let req = initReq 47 | { method = "POST" 48 | , path = "/api/auth/login" 49 | , requestBody = RequestBodyLBS $ encode auth 50 | } 51 | resp <- liftIO $ httpLbs req mgr 52 | case responseStatus resp of 53 | (Status 200 _) -> 54 | return $ Right $ responseCookieJar resp 55 | _ -> 56 | Left <$> parseOrErr req resp 57 | 58 | getUser :: HttpClient r m => Session -> m D.Email 59 | getUser session = do 60 | State initReq mgr <- asks getter 61 | let req = initReq 62 | { method = "GET" 63 | , path = "/api/users" 64 | , cookieJar = Just session 65 | } 66 | resp <- liftIO $ httpLbs req mgr 67 | case responseStatus resp of 68 | (Status 200 _) -> 69 | parseOrErr req resp 70 | _ -> 71 | throw $ UnexpectedResponse req resp -------------------------------------------------------------------------------- /12/src/Adapter/HTTP/API/Client/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Client.Common where 2 | 3 | import ClassyPrelude 4 | import Network.HTTP.Client 5 | import Network.HTTP.Client.TLS 6 | import Data.Has 7 | import Data.Aeson 8 | 9 | newtype Config = Config 10 | { configUrl :: String 11 | } 12 | 13 | data State = State 14 | { stateInitReq :: Request 15 | , stateManager :: Manager 16 | } 17 | 18 | type HttpClient r m = (MonadReader r m, Has State r, MonadIO m, MonadThrow m) 19 | 20 | type Session = CookieJar 21 | 22 | data UnexpectedResponse a = 23 | UnexpectedResponse Request (Response a) deriving (Show) 24 | 25 | instance (Typeable a, Show a) => Exception (UnexpectedResponse a) 26 | 27 | -- * Initialize 28 | 29 | withState :: Config -> (State -> IO a) -> IO a 30 | withState cfg action = do 31 | mgr <- newManager tlsManagerSettings 32 | initReq <- parseRequest $ configUrl cfg 33 | let initReqWithJson = 34 | initReq { requestHeaders = 35 | [("Content-Type", "application/json; charset=utf-8")] 36 | } 37 | action $ State initReqWithJson mgr 38 | 39 | -- * Helpers 40 | 41 | parseOrErr :: (MonadThrow m, FromJSON a) 42 | => Request -> Response LByteString -> m a 43 | parseOrErr req resp = 44 | case eitherDecode' $ responseBody resp of 45 | Left _ -> throw $ UnexpectedResponse req resp 46 | Right a -> return a -------------------------------------------------------------------------------- /12/src/Adapter/HTTP/API/Server/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Server.Auth where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Domain.Auth.Types 6 | import qualified Text.Digestive.Form as DF 7 | import Text.Digestive.Form ((.:)) 8 | import Adapter.HTTP.Common 9 | import Adapter.HTTP.API.Server.Common 10 | import Adapter.HTTP.API.Types.Auth () 11 | import Network.HTTP.Types.Status 12 | import Katip 13 | 14 | -- * Routes 15 | 16 | routes :: ( ScottyError e, MonadIO m, KatipContext m, AuthService m) 17 | => ScottyT e m () 18 | routes = do 19 | -- register 20 | post "/api/auth/register" $ do 21 | input <- parseAndValidateJSON authForm 22 | domainResult <- lift $ register input 23 | case domainResult of 24 | Left err -> do 25 | status status400 26 | json err 27 | Right _ -> 28 | return () 29 | 30 | -- verify email 31 | post "/api/auth/verifyEmail" $ do 32 | input <- parseAndValidateJSON verifyEmailForm 33 | domainResult <- lift $ verifyEmail input 34 | case domainResult of 35 | Left err -> do 36 | status status400 37 | json err 38 | Right _ -> 39 | return () 40 | 41 | -- login 42 | post "/api/auth/login" $ do 43 | input <- parseAndValidateJSON authForm 44 | domainResult <- lift $ login input 45 | case domainResult of 46 | Left err -> do 47 | status status400 48 | json err 49 | Right sId -> do 50 | setSessionIdInCookie sId 51 | return () 52 | 53 | -- get user 54 | get "/api/users" $ do 55 | userId <- reqCurrentUserId 56 | mayEmail <- lift $ getUser userId 57 | case mayEmail of 58 | Nothing -> 59 | raise $ stringError "Should not happen: SessionId map to invalid UserId" 60 | Just email -> 61 | json email 62 | 63 | -- * Forms 64 | 65 | verifyEmailForm :: (Monad m) => DF.Form [Text] m VerificationCode 66 | verifyEmailForm = DF.text Nothing 67 | 68 | authForm :: (Monad m) => DF.Form [Text] m Auth 69 | authForm = 70 | Auth <$> "email" .: emailForm 71 | <*> "password" .: passwordForm 72 | where 73 | emailForm = DF.validate (toResult . mkEmail) (DF.text Nothing) 74 | passwordForm = DF.validate (toResult . mkPassword) (DF.text Nothing) -------------------------------------------------------------------------------- /12/src/Adapter/HTTP/API/Server/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Server.Common where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Domain.Auth.Types 6 | import qualified Text.Digestive.Form as DF 7 | import qualified Text.Digestive.Aeson as DF 8 | import Data.Aeson hiding (json) 9 | import Network.HTTP.Types.Status 10 | import Adapter.HTTP.Common 11 | 12 | -- * Forms 13 | 14 | parseAndValidateJSON :: (ScottyError e, MonadIO m, ToJSON v) 15 | => DF.Form v m a -> ActionT e m a 16 | parseAndValidateJSON form = do 17 | val <- jsonData `rescue` (\_ -> return Null) 18 | validationResult <- lift $ DF.digestJSON form val 19 | case validationResult of 20 | (v, Nothing) -> do 21 | status status400 22 | json $ DF.jsonErrors v 23 | finish 24 | (_, Just result) -> 25 | return result 26 | 27 | -- * Sessions 28 | 29 | reqCurrentUserId :: (AuthService m, ScottyError e) => ActionT e m UserId 30 | reqCurrentUserId = do 31 | mayUserId <- getCurrentUserId 32 | case mayUserId of 33 | Nothing -> do 34 | status status401 35 | json ("AuthRequired" :: Text) 36 | finish 37 | Just userId -> 38 | return userId -------------------------------------------------------------------------------- /12/src/Adapter/HTTP/API/Server/Main.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Server.Main where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Network.HTTP.Types.Status 6 | import qualified Adapter.HTTP.API.Server.Auth as Auth 7 | import Domain.Auth.Types 8 | import Katip 9 | import Network.Wai 10 | import Network.Wai.Middleware.Gzip 11 | 12 | main :: ( MonadIO m, KatipContext m, AuthService m) 13 | => (m Response -> IO Response) -> IO Application 14 | main runner = 15 | scottyAppT runner routes 16 | 17 | routes :: ( MonadIO m, KatipContext m, AuthService m) 18 | => ScottyT LText m () 19 | routes = do 20 | middleware $ gzip $ def { gzipFiles = GzipCompress } 21 | 22 | Auth.routes 23 | 24 | notFound $ do 25 | status status404 26 | json ("NotFound" :: Text) 27 | 28 | defaultHandler $ \e -> do 29 | lift $ $(logTM) ErrorS $ "Unhandled error: " <> ls (showError e) 30 | status status500 31 | json ("InternalServerError" :: Text) 32 | -------------------------------------------------------------------------------- /12/src/Adapter/HTTP/API/Types/AesonHelper.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.API.Types.AesonHelper where 2 | 3 | import ClassyPrelude 4 | import Data.Aeson.TH 5 | import Data.Aeson.Types 6 | import Language.Haskell.TH.Syntax 7 | 8 | withSmartConstructor :: (a -> Either [Text] b) -> a -> Parser b 9 | withSmartConstructor constructor a = 10 | case constructor a of 11 | Left errs -> fail $ intercalate ". " . map unpack $ errs 12 | Right val -> return val 13 | 14 | deriveJSONRecord :: Name -> Q [Dec] 15 | deriveJSONRecord record = 16 | let lowerCaseFirst (y:ys) = toLower [y] <> ys 17 | lowerCaseFirst "" = "" 18 | structName = nameBase record 19 | opts = defaultOptions 20 | { fieldLabelModifier = lowerCaseFirst . drop (length structName) 21 | } 22 | in deriveJSON opts record 23 | 24 | deriveJSONSumType :: Name -> Q [Dec] 25 | deriveJSONSumType record = 26 | let structName = nameBase record 27 | opts = defaultOptions 28 | { constructorTagModifier = drop (length structName) 29 | , tagSingleConstructors = True 30 | } 31 | in deriveJSON opts record 32 | 33 | deriveToJSONUnwrap :: Name -> Q [Dec] 34 | deriveToJSONUnwrap = 35 | let opts = defaultOptions { unwrapUnaryRecords = True } 36 | in deriveToJSON opts -------------------------------------------------------------------------------- /12/src/Adapter/HTTP/API/Types/Auth.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Adapter.HTTP.API.Types.Auth where 4 | 5 | import ClassyPrelude 6 | import Domain.Auth.Types 7 | import Data.Aeson 8 | import Adapter.HTTP.API.Types.AesonHelper 9 | 10 | instance FromJSON Email where 11 | parseJSON = 12 | withText "Email" $ withSmartConstructor mkEmail 13 | 14 | instance FromJSON Password where 15 | parseJSON = 16 | withText "Password" $ withSmartConstructor mkPassword 17 | 18 | $(map concat . sequence $ 19 | [ deriveJSONRecord ''Auth 20 | , deriveToJSONUnwrap ''Email 21 | , deriveToJSONUnwrap ''Password 22 | , deriveJSONSumType ''RegistrationError 23 | , deriveJSONSumType ''EmailVerificationError 24 | , deriveJSONSumType ''LoginError 25 | ]) -------------------------------------------------------------------------------- /12/src/Adapter/HTTP/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Common where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Blaze.ByteString.Builder (toLazyByteString) 6 | import Web.Cookie 7 | import Domain.Auth.Types 8 | import Data.Time.Lens 9 | import qualified Text.Digestive.Types as DF 10 | 11 | -- * Forms 12 | 13 | toResult :: Either e a -> DF.Result e a 14 | toResult = either DF.Error DF.Success 15 | 16 | -- * Cookies 17 | 18 | setCookie :: (Monad m) => SetCookie -> ActionT e m () 19 | setCookie = setHeader "Set-Cookie" . decodeUtf8 . toLazyByteString . renderSetCookie 20 | 21 | getCookie :: (ScottyError e, Monad m) => Text -> ActionT e m (Maybe Text) 22 | getCookie key = do 23 | mCookieStr <- header "Cookie" 24 | return $ do 25 | cookie <- parseCookies . encodeUtf8 . toStrict <$> mCookieStr 26 | let bsKey = encodeUtf8 key 27 | val <- lookup bsKey cookie 28 | return $ decodeUtf8 val 29 | 30 | -- * Sessions 31 | 32 | setSessionIdInCookie :: (MonadIO m, ScottyError e) => SessionId -> ActionT e m () 33 | setSessionIdInCookie sId = do 34 | curTime <- liftIO getCurrentTime 35 | setCookie $ def { setCookieName = "sId" 36 | , setCookiePath = Just "/" 37 | , setCookieValue = encodeUtf8 sId 38 | , setCookieExpires = Just $ modL month (+ 1) curTime 39 | , setCookieHttpOnly = True 40 | , setCookieSecure = False 41 | , setCookieSameSite = Just sameSiteLax 42 | } 43 | 44 | getCurrentUserId :: (AuthService m, ScottyError e) => ActionT e m (Maybe UserId) 45 | getCurrentUserId = do 46 | maySessionId <- getCookie "sId" 47 | case maySessionId of 48 | Nothing -> return Nothing 49 | Just sId -> lift $ resolveSessionId sId -------------------------------------------------------------------------------- /12/src/Adapter/HTTP/Main.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Main where 2 | 3 | import ClassyPrelude 4 | import qualified Adapter.HTTP.API.Server.Main as API 5 | import qualified Adapter.HTTP.Web.Main as Web 6 | import Domain.Auth.Types 7 | import Katip 8 | import Network.Wai 9 | import Network.Wai.Handler.Warp 10 | import Network.Wai.Middleware.Vhost 11 | 12 | app :: (KatipContext m, AuthService m) 13 | => (m Response -> IO Response) -> IO Application 14 | app runner = do 15 | web <- Web.main runner 16 | api <- API.main runner 17 | return $ vhost [(pathBeginsWith "api", api)] web 18 | where 19 | pathBeginsWith path req = headMay (pathInfo req) == Just path 20 | 21 | main :: (KatipContext m, AuthService m) 22 | => Int -> (m Response -> IO Response) -> IO () 23 | main port runner = 24 | app runner >>= run port 25 | -------------------------------------------------------------------------------- /12/src/Adapter/HTTP/Web/Common.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Web.Common where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Domain.Auth.Types 6 | import qualified Text.Digestive.View as DF 7 | import Text.Blaze.Html5 ((!)) 8 | import qualified Text.Blaze.Html5 as H 9 | import qualified Text.Blaze.Html5.Attributes as A 10 | import qualified Text.Blaze.Html.Renderer.Text as H 11 | import Adapter.HTTP.Common 12 | 13 | -- * Views 14 | 15 | renderHtml :: (ScottyError e, Monad m) => H.Html -> ActionT e m () 16 | renderHtml = html . H.renderHtml 17 | 18 | mainLayout :: Text -> H.Html -> H.Html 19 | mainLayout title content = 20 | H.docTypeHtml $ do 21 | H.head $ do 22 | favicon "/images/logo.png" 23 | H.title $ H.toHtml title 24 | H.body $ do 25 | H.div $ H.img ! A.src "/images/logo.png" 26 | H.div content 27 | where 28 | favicon path = 29 | H.link ! A.rel "icon" 30 | ! A.type_ "image/png" 31 | ! A.href path 32 | 33 | formLayout :: DF.View a -> Text -> H.Html -> H.Html 34 | formLayout view action = 35 | H.form ! A.method "POST" 36 | ! A.enctype (H.toValue $ show $ DF.viewEncType view) 37 | ! A.action (H.toValue action) 38 | 39 | -- * Sessions 40 | 41 | reqCurrentUserId :: (AuthService m, ScottyError e) => ActionT e m UserId 42 | reqCurrentUserId = do 43 | mUserId <- getCurrentUserId 44 | case mUserId of 45 | Nothing -> 46 | redirect "/auth/login" 47 | Just userId -> 48 | return userId -------------------------------------------------------------------------------- /12/src/Adapter/HTTP/Web/Main.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Web.Main where 2 | 3 | import ClassyPrelude 4 | import Web.Scotty.Trans 5 | import Network.HTTP.Types.Status 6 | import qualified Adapter.HTTP.Web.Auth as Auth 7 | import Domain.Auth.Types 8 | import Katip 9 | import Network.Wai 10 | import Network.Wai.Middleware.Static 11 | import Network.Wai.Middleware.Gzip 12 | 13 | main :: ( MonadIO m, KatipContext m, AuthService m) 14 | => (m Response -> IO Response) -> IO Application 15 | main runner = do 16 | cacheContainer <- initCaching PublicStaticCaching 17 | scottyAppT runner $ routes cacheContainer 18 | 19 | routes :: ( MonadIO m, KatipContext m, AuthService m) 20 | => CacheContainer -> ScottyT LText m () 21 | routes cacheContainer = do 22 | middleware $ 23 | gzip $ def { gzipFiles = GzipCompress } 24 | middleware $ 25 | staticPolicy' cacheContainer (addBase "src/Adapter/HTTP/Web/static") 26 | 27 | Auth.routes 28 | 29 | notFound $ do 30 | status status404 31 | text "Not found" 32 | 33 | defaultHandler $ \e -> do 34 | lift $ $(logTM) ErrorS $ "Unhandled error: " <> ls (showError e) 35 | status status500 36 | text "Internal server error!" 37 | -------------------------------------------------------------------------------- /12/src/Adapter/HTTP/Web/static/images/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-webdev-haskell/17b90c06030def254bb0497b9e357f5d3b96d0cf/12/src/Adapter/HTTP/Web/static/images/logo.png -------------------------------------------------------------------------------- /12/src/Adapter/PostgreSQL/Migrations/00000_auths.sql: -------------------------------------------------------------------------------- 1 | create extension citext; 2 | create extension pgcrypto; 3 | 4 | create table auths ( 5 | id bigserial primary key not null, 6 | pass text not null, 7 | email citext not null unique, 8 | email_verification_code text not null, 9 | is_email_verified boolean not null 10 | ); -------------------------------------------------------------------------------- /12/src/Adapter/RabbitMQ/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.RabbitMQ.Auth where 2 | 3 | import ClassyPrelude 4 | import Adapter.RabbitMQ.Common 5 | import Network.AMQP 6 | import Katip 7 | import Data.Aeson 8 | import Data.Aeson.TH 9 | import qualified Domain.Auth.Types as D 10 | 11 | data EmailVerificationPayload = EmailVerificationPayload 12 | { emailVerificationPayloadEmail :: Text 13 | , emailVerificationPayloadVerificationCode :: Text 14 | } 15 | 16 | 17 | class (Monad m) => EmailVerificationSender m where 18 | sendEmailVerification :: D.Email -> D.VerificationCode -> m () 19 | 20 | 21 | init :: (EmailVerificationSender m, KatipContext m, MonadCatch m) 22 | => State -> (m Bool -> IO Bool) -> IO () 23 | init state runner = do 24 | initQueue state "verifyEmail" "auth" "userRegistered" 25 | initConsumer state "verifyEmail" (consumeEmailVerification runner) 26 | 27 | consumeEmailVerification :: (EmailVerificationSender m, KatipContext m, MonadCatch m) 28 | => (m Bool -> IO Bool) -> Message -> IO Bool 29 | consumeEmailVerification runner msg = 30 | runner $ consumeAndProcess msg handler 31 | where 32 | handler payload = 33 | case D.mkEmail (emailVerificationPayloadEmail payload) of 34 | Left err -> withMsgAndErr msg err $ do 35 | $(logTM) ErrorS "Email format is invalid. Rejecting." 36 | return False 37 | Right email -> do 38 | let vCode = emailVerificationPayloadVerificationCode payload 39 | sendEmailVerification email vCode 40 | return True 41 | 42 | notifyEmailVerification :: (Rabbit r m) => D.Email -> D.VerificationCode -> m () 43 | notifyEmailVerification email vCode = 44 | let payload = EmailVerificationPayload (D.rawEmail email) vCode 45 | in publish "auth" "userRegistered" payload 46 | 47 | -- JSON serde 48 | 49 | $(let structName = fromMaybe "" . lastMay . splitElem '.' . show $ ''EmailVerificationPayload 50 | lowercaseFirst (x:xs) = toLower [x] <> xs 51 | lowercaseFirst xs = xs 52 | options = defaultOptions 53 | { fieldLabelModifier = lowercaseFirst . drop (length structName) 54 | } 55 | in deriveJSON options ''EmailVerificationPayload) -------------------------------------------------------------------------------- /12/src/Adapter/Redis/Auth.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Redis.Auth where 2 | 3 | import ClassyPrelude 4 | import qualified Domain.Auth.Types as D 5 | import Text.StringRandom 6 | import Data.Has 7 | import qualified Database.Redis as R 8 | 9 | type State = R.Connection 10 | 11 | type Redis r m = (Has State r, MonadReader r m, MonadIO m, MonadThrow m) 12 | 13 | -- | Create state from redis url string. 14 | -- format: redis://user:pass@host:port/db 15 | -- sample: redis://abc:def@localhost:6379/0 16 | withState :: String -> (State -> IO a) -> IO a 17 | withState connUrl action = 18 | case R.parseConnectInfo connUrl of 19 | Left _ -> 20 | throwString $ "Invalid Redis conn URL: " <> connUrl 21 | Right connInfo -> do 22 | conn <- R.checkedConnect connInfo 23 | action conn 24 | 25 | withConn :: Redis r m => R.Redis a -> m a 26 | withConn action = do 27 | conn <- asks getter 28 | liftIO $ R.runRedis conn action 29 | 30 | newSession :: Redis r m => D.UserId -> m D.SessionId 31 | newSession userId = do 32 | sId <- liftIO $ stringRandomIO "[a-zA-Z0-9]{32}" 33 | result <- withConn $ R.set (encodeUtf8 sId) (fromString . show $ userId) 34 | case result of 35 | Right R.Ok -> return sId 36 | err -> throwString $ "Unexpected redis error: " <> show err 37 | 38 | findUserIdBySessionId :: Redis r m => D.SessionId -> m (Maybe D.UserId) 39 | findUserIdBySessionId sId = do 40 | result <- withConn $ R.get (encodeUtf8 sId) 41 | return $ case result of 42 | Right (Just uIdStr) -> readMay . unpack . decodeUtf8 $ uIdStr 43 | err -> throwString $ "Unexpected redis error: " <> show err 44 | -------------------------------------------------------------------------------- /12/src/Config.hs: -------------------------------------------------------------------------------- 1 | module Config where 2 | 3 | import ClassyPrelude 4 | import System.Environment 5 | import qualified Adapter.PostgreSQL.Auth as PG 6 | import qualified Adapter.RabbitMQ.Common as MQ 7 | 8 | data Config = Config 9 | { configPort :: Int 10 | , configRedis :: String 11 | , configMQ :: MQ.Config 12 | , configPG :: PG.Config 13 | } deriving (Eq, Show) 14 | 15 | fromEnv :: IO Config 16 | fromEnv = Config 17 | <$> envRead "PORT" 18 | <*> getEnv "REDIS_URL" 19 | <*> (MQ.Config 20 | <$> getEnv "MQ_URL" 21 | <*> pure 16 22 | ) 23 | <*> (PG.Config 24 | <$> envFromString "PG_URL" 25 | <*> pure 2 26 | <*> pure 5 27 | <*> pure 10 28 | ) 29 | 30 | devConfig :: Config 31 | devConfig = Config 32 | { configPort = 3000 33 | , configRedis = "redis://localhost:6379/0" 34 | , configMQ = MQ.Config 35 | { MQ.configUrl = "amqp://guest:guest@localhost:5672/%2F" 36 | , MQ.configPrefetchCount = 16 37 | } 38 | , configPG = PG.Config 39 | { PG.configUrl = "postgresql://localhost/hauth" 40 | , PG.configStripeCount = 2 41 | , PG.configMaxOpenConnPerStripe = 5 42 | , PG.configIdleConnTimeout = 10 43 | } 44 | } 45 | 46 | -- * Helpers 47 | 48 | envFromString :: (IsString a) => String -> IO a 49 | envFromString key = fromString <$> getEnv key 50 | 51 | envRead :: Read a => String -> IO a 52 | envRead key = do 53 | rawVal <- getEnv key 54 | case readMay rawVal of 55 | Just val -> return val 56 | Nothing -> throwString $ key <> ": Unable to parse " <> rawVal 57 | -------------------------------------------------------------------------------- /12/src/Domain/Auth/Service.hs: -------------------------------------------------------------------------------- 1 | module Domain.Auth.Service where 2 | 3 | import ClassyPrelude 4 | import Domain.Auth.Types 5 | import Control.Monad.Except 6 | import Katip 7 | 8 | class (Monad m) => AuthRepo m where 9 | addAuth :: Auth -> m (Either RegistrationError (UserId, VerificationCode)) 10 | setEmailAsVerified :: VerificationCode 11 | -> m (Either EmailVerificationError (UserId, Email)) 12 | findUserByAuth :: Auth -> m (Maybe (UserId, Bool)) 13 | findEmailFromUserId :: UserId -> m (Maybe Email) 14 | 15 | class (Monad m) => EmailVerificationNotif m where 16 | notifyEmailVerification :: Email -> VerificationCode -> m () 17 | 18 | class (Monad m) => SessionRepo m where 19 | newSession :: UserId -> m SessionId 20 | findUserIdBySessionId :: SessionId -> m (Maybe UserId) 21 | 22 | 23 | withUserIdContext :: (KatipContext m) => UserId -> m a -> m a 24 | withUserIdContext uId = katipAddContext (sl "userId" uId) 25 | 26 | register :: (KatipContext m, AuthRepo m, EmailVerificationNotif m) 27 | => Auth -> m (Either RegistrationError ()) 28 | register auth = runExceptT $ do 29 | (uId, vCode) <- ExceptT $ addAuth auth 30 | let email = authEmail auth 31 | lift $ notifyEmailVerification email vCode 32 | withUserIdContext uId $ 33 | $(logTM) InfoS $ ls (rawEmail email) <> " is registered successfully" 34 | 35 | verifyEmail :: (KatipContext m, AuthRepo m) 36 | => VerificationCode -> m (Either EmailVerificationError ()) 37 | verifyEmail vCode = runExceptT $ do 38 | (uId, email) <- ExceptT $ setEmailAsVerified vCode 39 | withUserIdContext uId $ 40 | $(logTM) InfoS $ ls (rawEmail email) <> " is verified successfully" 41 | return () 42 | 43 | login :: (KatipContext m, AuthRepo m, SessionRepo m) 44 | => Auth -> m (Either LoginError SessionId) 45 | login auth = runExceptT $ do 46 | result <- lift $ findUserByAuth auth 47 | case result of 48 | Nothing -> throwError LoginErrorInvalidAuth 49 | Just (_, False) -> throwError LoginErrorEmailNotVerified 50 | Just (uId, _) -> withUserIdContext uId . lift $ do 51 | sId <- newSession uId 52 | $(logTM) InfoS $ ls (rawEmail $ authEmail auth) <> " logged in successfully" 53 | return sId 54 | 55 | resolveSessionId :: (SessionRepo m) => SessionId -> m (Maybe UserId) 56 | resolveSessionId = findUserIdBySessionId 57 | 58 | getUser :: (AuthRepo m) => UserId -> m (Maybe Email) 59 | getUser = findEmailFromUserId 60 | -------------------------------------------------------------------------------- /12/src/Domain/Auth/Types.hs: -------------------------------------------------------------------------------- 1 | module Domain.Auth.Types ( 2 | -- * Types 3 | Auth(..), 4 | Email(rawEmail), 5 | mkEmail, 6 | Password(rawPassword), 7 | mkPassword, 8 | UserId, 9 | VerificationCode, 10 | SessionId, 11 | RegistrationError(..), 12 | EmailVerificationError(..), 13 | LoginError(..), 14 | 15 | -- * Services 16 | AuthService(..) 17 | ) where 18 | 19 | import ClassyPrelude 20 | import Domain.Validation 21 | import Text.Regex.PCRE.Heavy 22 | 23 | newtype Email = Email { rawEmail :: Text } deriving (Show, Eq, Ord) 24 | 25 | mkEmail :: Text -> Either [ErrMsg] Email 26 | mkEmail = 27 | validate Email 28 | [ regexMatches 29 | [re|^[A-Z0-9a-z._%+-]+@[A-Za-z0-9.-]+\.[A-Za-z]{2,64}$|] 30 | "Not a valid email" 31 | ] 32 | 33 | newtype Password = Password { rawPassword :: Text } deriving (Show, Eq) 34 | 35 | mkPassword :: Text -> Either [ErrMsg] Password 36 | mkPassword = 37 | validate Password 38 | [ lengthBetween 5 50 "Should between 5 and 50" 39 | , regexMatches [re|\d|] "Should contain number" 40 | , regexMatches [re|[A-Z]|] "Should contain uppercase letter" 41 | , regexMatches [re|[a-z]|] "Should contain lowercase letter" 42 | ] 43 | 44 | data Auth = Auth 45 | { authEmail :: Email 46 | , authPassword :: Password 47 | } deriving (Show, Eq) 48 | 49 | type UserId = Int 50 | 51 | type VerificationCode = Text 52 | 53 | type SessionId = Text 54 | 55 | data RegistrationError 56 | = RegistrationErrorEmailTaken 57 | deriving (Show, Eq) 58 | 59 | data EmailVerificationError 60 | = EmailVerificationErrorInvalidCode 61 | deriving (Show, Eq) 62 | 63 | data LoginError 64 | = LoginErrorInvalidAuth 65 | | LoginErrorEmailNotVerified 66 | deriving (Show, Eq) 67 | 68 | 69 | class (Monad m) => AuthService m where 70 | register :: Auth -> m (Either RegistrationError ()) 71 | verifyEmail :: VerificationCode -> m (Either EmailVerificationError ()) 72 | login :: Auth -> m (Either LoginError SessionId) 73 | resolveSessionId :: SessionId -> m (Maybe UserId) 74 | getUser :: UserId -> m (Maybe Email) 75 | -------------------------------------------------------------------------------- /12/src/Domain/Validation.hs: -------------------------------------------------------------------------------- 1 | module Domain.Validation where 2 | 3 | import ClassyPrelude 4 | import Text.Regex.PCRE.Heavy 5 | 6 | type ErrMsg = Text 7 | type Validation a = a -> Maybe ErrMsg 8 | 9 | validate :: (a -> b) -> [Validation a] -> a -> Either [ErrMsg] b 10 | validate constructor validations val = 11 | case concatMap (\f -> maybeToList $ f val) validations of 12 | [] -> Right $ constructor val 13 | errs -> Left errs 14 | 15 | rangeBetween :: (Ord a) => a -> a -> ErrMsg -> Validation a 16 | rangeBetween minRange maxRange msg val = 17 | if val >= minRange && val <= maxRange then Nothing else Just msg 18 | 19 | lengthBetween :: (MonoFoldable a) => Int -> Int -> ErrMsg -> Validation a 20 | lengthBetween minLen maxLen msg val = 21 | rangeBetween minLen maxLen msg (length val) 22 | 23 | regexMatches :: Regex -> ErrMsg -> Validation Text 24 | regexMatches regex msg val = 25 | if val =~ regex then Nothing else Just msg 26 | -------------------------------------------------------------------------------- /12/test/Adapter/HTTP/Fixture.hs: -------------------------------------------------------------------------------- 1 | module Adapter.HTTP.Fixture 2 | ( emptyFixture 3 | , app 4 | , AuthService 5 | , Fixture(..) 6 | ) where 7 | 8 | import ClassyPrelude 9 | import Domain.Auth.Types 10 | import Katip 11 | import Network.Wai 12 | import qualified Adapter.HTTP.Main as HTTP 13 | import Fixture 14 | 15 | data Fixture m = Fixture 16 | { _register :: Auth -> m (Either RegistrationError ()) 17 | , _verifyEmail :: VerificationCode -> m (Either EmailVerificationError ()) 18 | , _login :: Auth -> m (Either LoginError SessionId) 19 | , _resolveSessionId :: SessionId -> m (Maybe UserId) 20 | , _getUser :: UserId -> m (Maybe Email) 21 | } 22 | 23 | emptyFixture :: Fixture IO 24 | emptyFixture = Fixture 25 | { _register = const unimplemented 26 | , _verifyEmail = const unimplemented 27 | , _login = const unimplemented 28 | , _resolveSessionId = const unimplemented 29 | , _getUser = const unimplemented 30 | } 31 | 32 | newtype App a = App 33 | { unApp :: ReaderT (Fixture IO) (KatipContextT IO) a 34 | } deriving ( Applicative, Functor, Monad, MonadReader (Fixture IO), MonadIO 35 | , KatipContext, Katip 36 | ) 37 | 38 | app :: Fixture IO -> IO Application 39 | app fixture = do 40 | le <- initLogEnv "HAuth" "test" 41 | let runner = runKatipContextT le () mempty . flip runReaderT fixture . unApp 42 | HTTP.app runner 43 | 44 | instance AuthService App where 45 | register = dispatch _register 46 | verifyEmail = dispatch _verifyEmail 47 | login = dispatch _login 48 | resolveSessionId = dispatch _resolveSessionId 49 | getUser = dispatch _getUser -------------------------------------------------------------------------------- /12/test/Adapter/Redis/AuthSpec.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Redis.AuthSpec (spec) where 2 | 3 | import ClassyPrelude 4 | import Test.Hspec 5 | import qualified Database.Redis as R 6 | import Adapter.Redis.Auth 7 | 8 | spec :: Spec 9 | spec = beforeAll initDB $ 10 | describe "findUserIdBySessionId" $ do 11 | it "should return Nothing if session is invalid" $ 12 | runTestApp (findUserIdBySessionId "invalidSession") 13 | `shouldReturn` Nothing 14 | it "should return valid user id if session is valid" $ do 15 | let uId = 1 16 | runTestApp (newSession uId >>= findUserIdBySessionId) 17 | `shouldReturn` Just uId 18 | 19 | initDB :: IO () 20 | initDB = do 21 | let connInfo = either (error "Invalid Redis conn URL") id 22 | $ R.parseConnectInfo testConf 23 | conn <- R.checkedConnect connInfo 24 | void $ R.runRedis conn R.flushdb 25 | 26 | testConf :: String 27 | testConf = "redis://localhost:6379/8" 28 | 29 | runTestApp :: ReaderT State IO a -> IO a 30 | runTestApp action = 31 | withState testConf $ runReaderT action -------------------------------------------------------------------------------- /12/test/ConfigSpec.hs: -------------------------------------------------------------------------------- 1 | module ConfigSpec (spec) where 2 | 3 | import ClassyPrelude 4 | import Test.Hspec 5 | import System.Environment 6 | import Config 7 | import qualified Adapter.PostgreSQL.Auth as PG 8 | import qualified Adapter.RabbitMQ.Common as MQ 9 | 10 | spec :: Spec 11 | spec = before initEnv $ do 12 | it "should fail if PORT is missing" $ do 13 | unsetEnv "PORT" 14 | void fromEnv `shouldThrow` anyException 15 | it "should fail if PORT is not a number" $ do 16 | setEnv "PORT" "NOT A NUMBER" 17 | void fromEnv `shouldThrow` anyException 18 | it "should fail if REDIS_URL is missing" $ do 19 | unsetEnv "REDIS_URL" 20 | void fromEnv `shouldThrow` anyException 21 | it "should fail if MQ_URL is missing" $ do 22 | unsetEnv "MQ_URL" 23 | void fromEnv `shouldThrow` anyException 24 | it "should fail if PG_URL is missing" $ do 25 | unsetEnv "PG_URL" 26 | void fromEnv `shouldThrow` anyException 27 | it "should parse config correctly" $ 28 | fromEnv `shouldReturn` Config 29 | { configPort = 1234 30 | , configRedis = "REDIS_URL" 31 | , configMQ = MQ.Config "MQ_URL" 16 32 | , configPG = PG.Config "PG_URL" 2 5 10 33 | } 34 | 35 | initEnv :: IO () 36 | initEnv = do 37 | setEnv "PORT" "1234" 38 | setEnv "REDIS_URL" "REDIS_URL" 39 | setEnv "MQ_URL" "MQ_URL" 40 | setEnv "PG_URL" "PG_URL" -------------------------------------------------------------------------------- /12/test/Domain/Auth/TypesSpec.hs: -------------------------------------------------------------------------------- 1 | module Domain.Auth.TypesSpec (spec) where 2 | 3 | import ClassyPrelude 4 | import Test.Hspec 5 | import Domain.Auth.Types 6 | 7 | spec :: Spec 8 | spec = do 9 | describe "mkEmail" $ do 10 | describe "should pass" $ 11 | mkEmailSpec "ecky@test.com" True 12 | describe "should fail" $ do 13 | mkEmailSpec "invalid email@test.com" False 14 | mkEmailSpec "email@test." False 15 | mkEmailSpec "test.com" False 16 | 17 | describe "mkPassword" $ do 18 | describe "should pass" $ 19 | mkPasswordSpec "abcDEF123" [] 20 | describe "should fail" $ do 21 | mkPasswordSpec "aA1" ["Should between 5 and 50"] 22 | mkPasswordSpec (fromString . take 51 . join $ repeat "aA1") ["Should between 5 and 50"] 23 | mkPasswordSpec "abcDEF" ["Should contain number"] 24 | mkPasswordSpec "abc123" ["Should contain uppercase letter"] 25 | mkPasswordSpec "ABC123" ["Should contain lowercase letter"] 26 | 27 | mkEmailSpec :: Text -> Bool -> Spec 28 | mkEmailSpec email isValid = 29 | it (unpack email) $ 30 | case (isValid, mkEmail email) of 31 | (True, result) -> 32 | result `shouldSatisfy` either (const False) ((email ==) . rawEmail) 33 | (False, result) -> 34 | result `shouldSatisfy` either (["Not a valid email"] ==) (const False) 35 | 36 | mkPasswordSpec :: Text -> [Text] -> Spec 37 | mkPasswordSpec password errMsgs = 38 | it (unpack password) $ 39 | case (errMsgs, mkPassword password) of 40 | ([], result) -> 41 | result `shouldSatisfy` either (const False) ((password ==) . rawPassword) 42 | (msgs, result) -> 43 | result `shouldSatisfy` either (msgs ==) (const False) -------------------------------------------------------------------------------- /12/test/Domain/ValidationSpec.hs: -------------------------------------------------------------------------------- 1 | module Domain.ValidationSpec (spec) where 2 | 3 | import ClassyPrelude 4 | import Test.Hspec 5 | import Domain.Validation 6 | import Text.Regex.PCRE.Heavy 7 | 8 | spec :: Spec 9 | spec = do 10 | describe "rangeBetween" $ do 11 | let validator = rangeBetween 1 10 "fail" :: Validation Int 12 | it "val < min should fail" $ 13 | validator 0 `shouldBe` Just "fail" 14 | it "val == min should pass" $ 15 | validator 1 `shouldBe` Nothing 16 | it "min < val < max should pass" $ 17 | validator 5 `shouldBe` Nothing 18 | it "val == max should pass" $ 19 | validator 10 `shouldBe` Nothing 20 | it "val > max should fail" $ 21 | validator 11 `shouldBe` Just "fail" 22 | 23 | describe "lengthBetween" $ do 24 | let validator = lengthBetween 1 10 "fail" :: Validation [Int] 25 | it "val < min should fail" $ 26 | validator [] `shouldBe` Just "fail" 27 | it "val == min should pass" $ 28 | validator [1] `shouldBe` Nothing 29 | it "min < val < max should pass" $ 30 | validator [1..5] `shouldBe` Nothing 31 | it "val == max should pass" $ 32 | validator [1..10] `shouldBe` Nothing 33 | it "val > max should fail" $ 34 | validator [1..11] `shouldBe` Just "fail" 35 | 36 | describe "regexMatches" $ do 37 | let validator = regexMatches [re|^hello|] "fail" 38 | it "if matches found then it should pass" $ 39 | validator "hello world" `shouldBe` Nothing 40 | it "if no match found then it should fail" $ 41 | validator "world hello" `shouldBe` Just "fail" -------------------------------------------------------------------------------- /12/test/Fixture.hs: -------------------------------------------------------------------------------- 1 | module Fixture where 2 | 3 | import ClassyPrelude 4 | 5 | unimplemented :: a 6 | unimplemented = error "unimplemented" 7 | 8 | dispatch :: (MonadIO m, MonadReader r m) 9 | => (r -> a -> IO b) 10 | -> (a -> m b) 11 | dispatch getter param = do 12 | func <- asks getter 13 | liftIO $ func param 14 | 15 | dispatch2 :: (MonadIO m, MonadReader r m) 16 | => (r -> a -> b -> IO c) 17 | -> (a -> b -> m c) 18 | dispatch2 getter param1 param2 = do 19 | func <- asks getter 20 | liftIO $ func param1 param2 21 | -------------------------------------------------------------------------------- /12/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} -------------------------------------------------------------------------------- /9781484237380.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/practical-webdev-haskell/17b90c06030def254bb0497b9e357f5d3b96d0cf/9781484237380.jpg -------------------------------------------------------------------------------- /Contributing.md: -------------------------------------------------------------------------------- 1 | # Contributing to Apress Source Code 2 | 3 | Copyright for Apress source code belongs to the author(s). However, under fair use you are encouraged to fork and contribute minor corrections and updates for the benefit of the author(s) and other readers. 4 | 5 | ## How to Contribute 6 | 7 | 1. Make sure you have a GitHub account. 8 | 2. Fork the repository for the relevant book. 9 | 3. Create a new branch on which to make your change, e.g. 10 | `git checkout -b my_code_contribution` 11 | 4. Commit your change. Include a commit message describing the correction. Please note that if your commit message is not clear, the correction will not be accepted. 12 | 5. Submit a pull request. 13 | 14 | Thank you for your contribution! -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Freeware License, some rights reserved 2 | 3 | Copyright (c) 2018 Ecky Putrady 4 | 5 | Permission is hereby granted, free of charge, to anyone obtaining a copy 6 | of this software and associated documentation files (the "Software"), 7 | to work with the Software within the limits of freeware distribution and fair use. 8 | This includes the rights to use, copy, and modify the Software for personal use. 9 | Users are also allowed and encouraged to submit corrections and modifications 10 | to the Software for the benefit of other users. 11 | 12 | It is not allowed to reuse, modify, or redistribute the Software for 13 | commercial use in any way, or for a user’s educational materials such as books 14 | or blog articles without prior permission from the copyright holder. 15 | 16 | The above copyright notice and this permission notice need to be included 17 | in all copies or substantial portions of the software. 18 | 19 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | AUTHORS OR COPYRIGHT HOLDERS OR APRESS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 25 | SOFTWARE. 26 | 27 | 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Apress Source Code 2 | 3 | This repository accompanies [*Practical Web Development with Haskell*](http://www.apress.com/9781484237380) by Ecky Putrady (Apress, 2018). 4 | 5 | [comment]: #cover 6 | ![Cover image](9781484237380.jpg) 7 | 8 | Download the files as a zip using the green button, or clone the repository to your machine using Git. 9 | 10 | ## Releases 11 | 12 | Release v1.0 corresponds to the code in the published book, without corrections or updates. 13 | 14 | ## Contributions 15 | 16 | See the file Contributing.md for more information on how you can contribute to this repository. --------------------------------------------------------------------------------