Browse Source

New command: server -- run a web server that responds to hook requests

master
Peter J. Jones 1 year ago
parent
commit
7833cf10ce
Signed by: Peter Jones <pjones@devalot.com> GPG Key ID: 9DAFAA8D01941E49

+ 1
- 1
LICENSE View File

@@ -1,4 +1,4 @@
1
-Copyright (c) 2017, Peter Jones <pjones@devalot.com>
1
+Copyright (c) 2017,2018 Peter Jones <pjones@devalot.com>
2 2
 All rights reserved.
3 3
 
4 4
 Redistribution and use in source and binary forms, with or without

+ 76
- 0
README.md View File

@@ -0,0 +1,76 @@
1
+# Trigger personal scripts from incoming HTTP requests
2
+
3
+Ever wish you could do something custom with all those web hooks
4
+offered by various web service providers?  This package provides an
5
+easy and safe way to do just that.
6
+
7
+## Example: Tagging a video will download and sync it to your phone
8
+
9
+In the `examples` directory there is a script named
10
+`download-video.sh`.  Here is how I use it:
11
+
12
+  * When I want to watch a video later, probably on an airplane, I tag
13
+    the video in my RSS feed reader (<https://feedly.com/>).
14
+
15
+  * That triggers an [IFTTT](https://ifttt.com/) applet which uses the
16
+    IFTTT support for calling a web hook and calls into this package.
17
+
18
+  * This package runs the `download-video.sh` script which downloads
19
+    the video to a directory that is automatically synced with my
20
+    phone.
21
+
22
+## How this package works
23
+
24
+This package includes an executable called `webhooks`.  This
25
+executable can be used to create new hooks from the command line or
26
+run a web server to respond to incoming requests.  A hook is just an
27
+indirect way to run a script if you know the hook's secret code.
28
+
29
+For security reasons, the web server does *not* run scripts directly.
30
+Instead, if the incoming request correctly maps to an existing hook,
31
+the request data will be appended to an existing file as JSON.
32
+
33
+"Okay, but how does appending JSON to a file help me?" you ask.  Good
34
+question.  Thanks to the magic of POSIX named pipes (FIFOs), you can
35
+feed that JSON data into a waiting script.
36
+
37
+## Setting up the example web hook
38
+
39
+  1. Run the HTTP server provided by this package:
40
+
41
+        $ webhooks server --port 3000
42
+
43
+  2. Create a new web hook that appends to a file.  In this example
44
+     we'll configure a hook to append to the file `/tmp/foo.pipe`:
45
+
46
+        $ webhooks create --append /tmp/foo.pipe
47
+
48
+     This command will print a secret code for the newly created hook.
49
+     (If you forget the hook's secret code you can use the `webhooks
50
+     list` command to look it up again.)
51
+
52
+  3. Run a script that creates the named pipe and then reads lines
53
+     from it.  In the `examples` directory there is a script that will
54
+     do this for you and then execute other commands as requests come
55
+     in.  (The commands receive JSONs request on their stdin.)
56
+
57
+        $ examples/watchfifo.sh -f /tmp/foo.pipe -- examples/download-video.sh
58
+
59
+  4. Use the hook's secret code to trigger your script.  In this
60
+     example we'll pretend that the secret code is `XXX`.
61
+
62
+        $ curl --data url=https://player.vimeo.com/video/148946917 \
63
+            http://localhost:3000/hooks/XXX
64
+
65
+     This leads to the `download-video.sh` script running and being
66
+     fed the following JSON:
67
+
68
+        {"url": "https://player.vimeo.com/video/148946917"}
69
+
70
+Ideally, you should run the `webhooks` server behind a reverse proxy
71
+that is properly configured for TLS.  This will prevent hook codes
72
+from being exposed to the network unencrypted.  To encourage this, the
73
+server only binds to the loopback device.
74
+
75
+More details about installing and running this package can be found in
76
+the installation guide.

+ 4
- 3
data/migrations/20171215T321320-hooks.sql View File

@@ -1,7 +1,6 @@
1
-create sequence hooks_id_seq;
2
-
1
+/* Hooks */
3 2
 create table hooks (
4
-  id         bigint primary key default nextval('hooks_id_seq'),
3
+  id         bigserial primary key,
5 4
   code       text not null,
6 5
   expires_at timestamp with time zone,
7 6
   action     json not null,
@@ -9,3 +8,5 @@ create table hooks (
9 8
   constraint hooks_unique_code unique(code),
10 9
   constraint hooks_nonblank_code check(code <> '')
11 10
 );
11
+
12
+create index on hooks (code, expires_at);

+ 15
- 0
docs/TODO.org View File

@@ -0,0 +1,15 @@
1
+* Before First Release
2
+** DONE Collapse single query parameters
3
+   CLOSED: [2018-01-10 Wed 14:55]
4
+   - When turning query parameters into JSON, all values will be
5
+     arrays.  To fix this, pull the element out of the array if the
6
+     length of the array is 1.
7
+** DONE Add support for HTTP GET
8
+   CLOSED: [2018-01-10 Wed 16:56]
9
+** DONE Add indexes to the migration (and change ownership of the sequence)
10
+   CLOSED: [2018-01-10 Wed 17:36]
11
+** DONE The default config file path is actually a directory
12
+   CLOSED: [2018-01-10 Wed 17:40]
13
+** DONE Add a -g option to watchfifo.sh to set the FIFO's group
14
+   CLOSED: [2018-01-10 Wed 17:49]
15
+** TODO Write an installation guide

+ 20
- 7
examples/watchfifo.sh View File

@@ -14,35 +14,40 @@
14 14
 #
15 15
 ################################################################################
16 16
 #
17
-# Execute a command for each line read from a fifo.
17
+# Execute a command for each line read from a FIFO.
18 18
 #
19 19
 # For example, to use in conjunction with the download-video.sh script:
20 20
 #
21 21
 # watchfifo.sh -f /tmp/download.fifo -- download-video.sh -d ~/Downloads
22 22
 #
23
-# Lines read from the fifo are piped into the given command's stdin.
23
+# Lines read from the FIFO are piped into the given command's stdin.
24 24
 #
25 25
 ################################################################################
26 26
 set -e
27 27
 option_fifo_file=""
28
+option_group=""
28 29
 
29 30
 ################################################################################
30 31
 usage () {
31 32
 cat <<EOF
32
-Usage: watchfifo.sh [options] -- command [arg, arg, ...]
33
+Usage: watchfifo.sh [options] -- command [arg1, arg2, ...]
33 34
 
34
-  -f FILE The fifo file to create and manage
35
+  -f FILE The FIFO file to create and manage
36
+  -g GRP  Set the FIFO file's group to GRP
35 37
   -h      This message
36 38
 
37 39
 EOF
38 40
 }
39 41
 
40 42
 ################################################################################
41
-while getopts "f:h" o; do
43
+while getopts "f:g:h" o; do
42 44
   case "${o}" in
43 45
     f) option_fifo_file=$OPTARG
44 46
        ;;
45 47
 
48
+    g) option_group=$OPTARG
49
+       ;;
50
+
46 51
     h) usage
47 52
        exit
48 53
        ;;
@@ -67,10 +72,14 @@ prepare() {
67 72
   fi
68 73
 
69 74
   if [ -r "$option_fifo_file" ]; then
70
-    die "fifo file exists, remove it first: $option_fifo_file"
75
+    die "FIFO file exists, remove it first: $option_fifo_file"
71 76
   fi
72 77
 
73
-  mkfifo -m 0622 "$option_fifo_file"
78
+  mkfifo -m 0620 "$option_fifo_file"
79
+
80
+  if [ -n "$option_group" ]; then
81
+    chgrp "$option_group" "$option_fifo_file"
82
+  fi
74 83
 }
75 84
 
76 85
 ################################################################################
@@ -79,6 +88,10 @@ cleanup() {
79 88
 }
80 89
 
81 90
 ################################################################################
91
+if [ $# -le 0 ]; then
92
+  die "please provide a command to run after -- "
93
+fi
94
+
82 95
 export IFS=$'\n'
83 96
 trap cleanup EXIT
84 97
 prepare

+ 4
- 1
lib/Web/Hooks/Personal/Config.hs View File

@@ -31,6 +31,7 @@ import Data.Bifunctor (bimap)
31 31
 import Data.Default (Default(def))
32 32
 import qualified Data.Yaml as YAML
33 33
 import System.Directory (XdgDirectory(..), getXdgDirectory, doesFileExist)
34
+import System.FilePath ((</>))
34 35
 
35 36
 --------------------------------------------------------------------------------
36 37
 -- Local imports:
@@ -64,7 +65,9 @@ instance FromJSON Config where
64 65
 --------------------------------------------------------------------------------
65 66
 -- | The path to the default configuration file.
66 67
 defaultPath :: (MonadIO m) => m FilePath
67
-defaultPath = liftIO (getXdgDirectory XdgConfig "webhooks")
68
+defaultPath = do
69
+  dir <- liftIO (getXdgDirectory XdgConfig "webhooks")
70
+  return (dir </> "config.yml")
68 71
 
69 72
 --------------------------------------------------------------------------------
70 73
 -- | Parse the given configuration file.

+ 3
- 3
lib/Web/Hooks/Personal/Internal/Action/Prim.hs View File

@@ -33,7 +33,7 @@ module Web.Hooks.Personal.Internal.Action.Prim
33 33
 import Control.Exception (SomeException, catch)
34 34
 import Control.Monad.IO.Class (MonadIO, liftIO)
35 35
 import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
36
-import Data.Aeson (ToJSON, FromJSON, encode)
36
+import Data.Aeson (ToJSON, FromJSON, encode, toJSON)
37 37
 import qualified Data.ByteString.Lazy as LBS
38 38
 import Data.Maybe (isJust)
39 39
 import Data.Monoid ((<>))
@@ -89,7 +89,7 @@ run :: (MonadIO m)
89 89
     -> m Status
90 90
     -- ^ Result status.
91 91
 
92
-run Config.Config{..} (Request v) a =
92
+run Config.Config{..} r a =
93 93
   statusFromEither <$> liftIO (catch (runExceptT action) handleE)
94 94
 
95 95
   where
@@ -110,7 +110,7 @@ run Config.Config{..} (Request v) a =
110 110
       assert exists (Invalid $ "file doesn't exist: " ++ file)
111 111
 
112 112
       -- Ensure it won't grow bigger than allowed.
113
-      let bs = encode v <> "\n"
113
+      let bs = encode (toJSON r) <> "\n"
114 114
           bsize = toInteger (LBS.length bs)
115 115
 
116 116
       size <- liftIO (getFileSize file)

+ 2
- 1
lib/Web/Hooks/Personal/Internal/Request/Config.hs View File

@@ -22,10 +22,11 @@ module Web.Hooks.Personal.Internal.Request.Config
22 22
 --------------------------------------------------------------------------------
23 23
 import Data.Aeson (FromJSON(parseJSON), withObject, (.:?), (.!=))
24 24
 import Data.Default (Default(def))
25
+import Data.Word (Word64)
25 26
 
26 27
 --------------------------------------------------------------------------------
27 28
 data Config = Config
28
-  { configMaxBodySize :: Int
29
+  { configMaxBodySize :: Word64
29 30
     -- ^ Maximum number of bytes to read from an HTTP body.
30 31
   }
31 32
 

+ 27
- 6
lib/Web/Hooks/Personal/Internal/Request/Prim.hs View File

@@ -31,19 +31,39 @@ import Data.Text (Text)
31 31
 import qualified Data.Text.Encoding as Text
32 32
 
33 33
 --------------------------------------------------------------------------------
34
-newtype Request = Request Aeson.Value
34
+-- | A type to represent the data sent with an HTTP request.
35
+data Request = RequestParams (Map Text Value)
36
+             | RequestJSON Aeson.Value
37
+
38
+--------------------------------------------------------------------------------
39
+-- | Helper type to collapse query parameters that only have one value.
40
+data Value = Single Text | Multiple [Text]
41
+
42
+--------------------------------------------------------------------------------
43
+instance Aeson.ToJSON Request where
44
+  toJSON (RequestParams p) = Aeson.toJSON p
45
+  toJSON (RequestJSON v)   = v
46
+
47
+--------------------------------------------------------------------------------
48
+instance Aeson.ToJSON Value where
49
+  toJSON (Single t)    = Aeson.String t
50
+  toJSON (Multiple ts) = Aeson.toJSON ts
35 51
 
36 52
 --------------------------------------------------------------------------------
37 53
 -- | Create a 'Request' from a string containing JSON data.
38 54
 fromJSON :: L.ByteString -> Maybe Request
39
-fromJSON = fmap Request . Aeson.decode
55
+fromJSON = fmap RequestJSON . Aeson.decode
40 56
 
41 57
 --------------------------------------------------------------------------------
42 58
 -- | Create a 'Request' from decoded query parameters.
43 59
 fromParams :: Map B.ByteString [B.ByteString] -> Maybe Request
44
-fromParams =
45
-    Just . Request . Aeson.toJSON . Map.fromList . map convert . Map.toList
60
+fromParams = Just . RequestParams . Map.fromList . map convert . Map.toList
46 61
   where
47
-    convert :: (B.ByteString, [B.ByteString]) -> (Text, [Text])
48
-    convert (k, vs) = (Text.decodeUtf8 k, map Text.decodeUtf8 vs)
62
+    convert :: (B.ByteString, [B.ByteString]) -> (Text, Value)
63
+    convert (k, vs) = ( Text.decodeUtf8 k
64
+                      , mkValue (map Text.decodeUtf8 vs)
65
+                      )
66
+
67
+    mkValue :: [Text] -> Value
68
+    mkValue [x] = Single x
69
+    mkValue xs  = Multiple xs

+ 5
- 5
personal-webhooks.cabal View File

@@ -5,7 +5,7 @@ license:       BSD2
5 5
 license-file:  LICENSE
6 6
 author:        Peter Jones <pjones@devalot.com>
7 7
 maintainer:    Peter Jones <pjones@devalot.com>
8
-copyright:     Copyright (c) 2017 Peter J. Jones
8
+copyright:     Copyright (c) 2017,2018 Peter J. Jones
9 9
 category:      Web
10 10
 build-type:    Simple
11 11
 cabal-version: >=1.10
@@ -41,6 +41,7 @@ library
41 41
     Web.Hooks.Personal.Env
42 42
     Web.Hooks.Personal.Hook
43 43
     Web.Hooks.Personal.Request
44
+    -- Web.Hooks.Personal.Internal
44 45
       -- Web.Hooks.Personal.Internal.Action
45 46
         Web.Hooks.Personal.Internal.Action.Config
46 47
         Web.Hooks.Personal.Internal.Action.Options
@@ -82,12 +83,8 @@ library
82 83
                , postgresql-simple           >= 0.5  && < 0.6
83 84
                , postgresql-simple-migration >= 0.1  && < 0.2
84 85
                , product-profunctors         >= 0.8  && < 0.9
85
-               , profunctors                 >= 5.2  && < 5.3
86 86
                , resource-pool               >= 0.2  && < 0.3
87 87
                , sandi                       >= 0.4  && < 0.5
88
-               , snap                        >= 1.0  && < 1.1
89
-               , snap-core                   >= 1.0  && < 1.1
90
-               , snap-server                 >= 1.0  && < 1.1
91 88
                , template-haskell            >= 2.11 && < 2.12
92 89
                , text                        >= 1.2  && < 1.3
93 90
                , time                        >= 1.6  && < 1.9
@@ -100,6 +97,7 @@ executable webhooks
100 97
     UI.Create
101 98
     UI.List
102 99
     UI.Run
100
+    UI.Server
103 101
 
104 102
   hs-source-dirs: src
105 103
   main-is: Main.hs
@@ -113,6 +111,8 @@ executable webhooks
113 111
                , opaleye
114 112
                , optparse-applicative
115 113
                , personal-webhooks
114
+               , snap-core >= 1.0 && < 1.1
115
+               , snap-server >= 1.0 && < 1.1
116 116
                , table-layout >= 0.8 && < 0.9
117 117
                , text
118 118
                , transformers

+ 6
- 7
personal-webhooks.nix View File

@@ -1,9 +1,9 @@
1 1
 { mkDerivation, aeson, base, bytestring, containers, cryptonite
2 2
 , data-default, directory, filepath, opaleye, optparse-applicative
3 3
 , postgresql-simple, postgresql-simple-migration
4
-, product-profunctors, profunctors, resource-pool, sandi, snap
5
-, snap-core, snap-server, stdenv, table-layout, template-haskell
6
-, text, time, transformers, yaml
4
+, product-profunctors, resource-pool, sandi, snap-core, snap-server
5
+, stdenv, table-layout, template-haskell, text, time, transformers
6
+, yaml
7 7
 }:
8 8
 mkDerivation {
9 9
   pname = "personal-webhooks";
@@ -15,13 +15,12 @@ mkDerivation {
15 15
   libraryHaskellDepends = [
16 16
     aeson base bytestring containers cryptonite data-default directory
17 17
     filepath opaleye optparse-applicative postgresql-simple
18
-    postgresql-simple-migration product-profunctors profunctors
19
-    resource-pool sandi snap snap-core snap-server template-haskell
20
-    text time transformers yaml
18
+    postgresql-simple-migration product-profunctors resource-pool sandi
19
+    template-haskell text time transformers yaml
21 20
   ];
22 21
   executableHaskellDepends = [
23 22
     aeson base bytestring data-default opaleye optparse-applicative
24
-    table-layout text transformers
23
+    snap-core snap-server table-layout text transformers
25 24
   ];
26 25
   description = "Trigger personal scripts from incoming HTTP requests";
27 26
   license = stdenv.lib.licenses.bsd2;

+ 7
- 0
src/Main.hs View File

@@ -27,6 +27,7 @@ import Options.Applicative
27 27
 import qualified UI.Create as Create
28 28
 import qualified UI.List as List
29 29
 import qualified UI.Run as Run
30
+import qualified UI.Server as Server
30 31
 import qualified Web.Hooks.Personal.Env as Env
31 32
 
32 33
 --------------------------------------------------------------------------------
@@ -34,6 +35,7 @@ import qualified Web.Hooks.Personal.Env as Env
34 35
 data Command = Create Create.Options -- ^ Create a new hook.
35 36
              | List List.Options     -- ^ List hooks.
36 37
              | Run Run.Options       -- ^ Run hooks.
38
+             | Server Server.Options -- ^ Web server.
37 39
 
38 40
 --------------------------------------------------------------------------------
39 41
 -- | Command line options
@@ -61,6 +63,7 @@ parser =
61 63
     <*> subparser (mconcat [ createCommand
62 64
                            , listCommand
63 65
                            , runCommand
66
+                           , serverCommand
64 67
                            ])
65 68
 
66 69
   where
@@ -77,6 +80,9 @@ parser =
77 80
     runCommand =
78 81
       mkCmd "run" "Run hooks" (Run <$> Run.parser)
79 82
 
83
+    serverCommand =
84
+      mkCmd "server" "Run the web server" (Server <$> Server.parser)
85
+
80 86
 --------------------------------------------------------------------------------
81 87
 -- | Main entry point.
82 88
 main :: IO ()
@@ -89,3 +95,4 @@ main = do
89 95
       Create o -> Create.run o
90 96
       List o   -> List.run o
91 97
       Run o    -> Run.run o
98
+      Server o -> Server.run o

+ 151
- 0
src/UI/Server.hs View File

@@ -0,0 +1,151 @@
1
+{-# LANGUAGE OverloadedStrings #-}
2
+{-# LANGUAGE RecordWildCards   #-}
3
+
4
+{-
5
+
6
+This file is part of the package personal-webhooks. It is subject to
7
+the license terms in the LICENSE file found in the top-level directory
8
+of this distribution and at:
9
+
10
+  git://git.devalot.com/personal-webhooks.git
11
+
12
+No part of this package, including this file, may be copied, modified,
13
+propagated, or distributed except according to the terms contained in
14
+the LICENSE file.
15
+
16
+-}
17
+
18
+--------------------------------------------------------------------------------
19
+module UI.Server
20
+  ( Options
21
+  , parser
22
+  , run
23
+  ) where
24
+
25
+--------------------------------------------------------------------------------
26
+-- Library Imports:
27
+import Control.Monad (mzero)
28
+import Control.Monad.IO.Class (MonadIO, liftIO)
29
+import Control.Monad.Trans.Class (lift)
30
+import Control.Monad.Trans.Maybe (MaybeT(..))
31
+import Control.Monad.Trans.Reader
32
+import Data.ByteString (ByteString)
33
+import qualified Data.ByteString as ByteString
34
+import Data.Monoid ((<>))
35
+import Data.Text (Text)
36
+import qualified Data.Text.Encoding as Text
37
+import Data.Word (Word64)
38
+import Options.Applicative
39
+import Snap.Core
40
+import qualified Snap.Http.Server as HTTP
41
+
42
+--------------------------------------------------------------------------------
43
+-- Local Imports:
44
+import qualified Web.Hooks.Personal.Action as Action
45
+import qualified Web.Hooks.Personal.Config as Config
46
+import qualified Web.Hooks.Personal.Database as Database
47
+import Web.Hooks.Personal.Env (Env)
48
+import qualified Web.Hooks.Personal.Env as Env
49
+import Web.Hooks.Personal.Hook (Hook)
50
+import qualified Web.Hooks.Personal.Hook as Hook
51
+import qualified Web.Hooks.Personal.Request as Request
52
+
53
+--------------------------------------------------------------------------------
54
+-- | Command line options.
55
+data Options = Options
56
+  { optionPort :: Int
57
+  }
58
+
59
+--------------------------------------------------------------------------------
60
+-- | Command line parser.
61
+parser :: Parser Options
62
+parser =
63
+  Options <$> option auto (mconcat [ long "port"
64
+                                   , short 'p'
65
+                                   , metavar "NUM"
66
+                                   , help "The port number to bind to"
67
+                                   ])
68
+
69
+--------------------------------------------------------------------------------
70
+-- | Fetch a hook from the database and run its action.
71
+findAndRunHook :: (MonadIO m)
72
+               => Env
73
+               -> Text
74
+               -> Request.Request
75
+               -> MaybeT m Action.Status
76
+
77
+findAndRunHook env code request = do
78
+    a <- Hook.hookAction <$> findByCode
79
+    Action.run actionConfig request a
80
+
81
+  where
82
+    findByCode :: (MonadIO m) => MaybeT m Hook
83
+    findByCode = listToMaybeT =<<
84
+                 Database.runQuery (Env.database env)
85
+                   (Hook.findBy $ Hook.HookCode code)
86
+
87
+    actionConfig :: Action.Config
88
+    actionConfig = Config.configAction (Env.config env)
89
+
90
+    listToMaybeT :: (Monad m) => [a] -> MaybeT m a
91
+    listToMaybeT []    = mzero
92
+    listToMaybeT (x:_) = return x
93
+
94
+--------------------------------------------------------------------------------
95
+-- | Routes.
96
+site :: Env -> Snap ()
97
+site env = route [ ("hooks/:hookcode", handler env) ]
98
+
99
+--------------------------------------------------------------------------------
100
+-- | Request handler.
101
+handler :: Env -> Snap ()
102
+handler env = do
103
+    -- Review the request and try to run a hook.
104
+    status <- runMaybeT $ do
105
+      rq <- lift getRequest
106
+
107
+      rdata <- -- Where the data comes from varies based on the request.
108
+        case (rqMethod rq, getHeader "Content-Type" rq) of
109
+          (GET,  _)                                        -> fromParams rq
110
+          (POST, Just "application/x-www-form-urlencoded") -> fromParams rq
111
+          (POST, Just "application/json")                  -> fromJSON
112
+          (_, _) {- Anything else is a failure -}          -> mzero
113
+
114
+      code <- MaybeT (getParam "hookcode")
115
+      findAndRunHook env (Text.decodeUtf8 code) rdata
116
+
117
+    -- Respond with the correct HTTP status code.
118
+    modifyResponse . setResponseCode $
119
+      case status of
120
+        Nothing -> 404
121
+        Just s  -> Action.statusToHTTP s
122
+
123
+  where
124
+    fromParams :: (Monad m) => Request -> MaybeT m Request.Request
125
+    fromParams = MaybeT . return . Request.fromParams . rqParams
126
+
127
+    fromJSON :: MaybeT Snap Request.Request
128
+    fromJSON = MaybeT (Request.fromJSON <$> readRequestBody (maxBytes env))
129
+
130
+    maxBytes :: Env -> Word64
131
+    maxBytes = Request.configMaxBodySize . Config.configRequest . Env.config
132
+
133
+--------------------------------------------------------------------------------
134
+-- | Snap server configuration.
135
+snapCfg :: MonadSnap m => Options -> HTTP.Config m a
136
+snapCfg Options{..} =
137
+    HTTP.setErrorLog  (HTTP.ConfigIoLog stdoutLog) $
138
+    HTTP.setAccessLog (HTTP.ConfigIoLog stdoutLog) $
139
+    HTTP.setPort      optionPort $
140
+    HTTP.setBind      "127.0.0.1"
141
+    HTTP.defaultConfig
142
+  where
143
+    stdoutLog :: ByteString -> IO ()
144
+    stdoutLog = ByteString.putStr . (<> "\n")
145
+
146
+--------------------------------------------------------------------------------
147
+-- | Run the @server@ command to receive HTTP requests.
148
+run :: (MonadIO m) => Options -> ReaderT Env m ()
149
+run options = do
150
+  env <- ask
151
+  liftIO $ HTTP.httpServe (snapCfg options) (site env)

Loading…
Cancel
Save