Browse Source

Initial import

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

+ 1
- 0
.gitignore View File

@@ -0,0 +1 @@
1
+/dist

+ 5
- 0
CHANGES.md View File

@@ -0,0 +1,5 @@
1
+# Revision history for personal-webhooks
2
+
3
+## 0.1.0.0  -- YYYY-mm-dd
4
+
5
+* First version. Released on an unsuspecting world.

+ 26
- 0
LICENSE View File

@@ -0,0 +1,26 @@
1
+Copyright (c) 2017, Peter Jones <pjones@devalot.com>
2
+All rights reserved.
3
+
4
+Redistribution and use in source and binary forms, with or without
5
+modification, are permitted provided that the following conditions are
6
+met:
7
+
8
+1. Redistributions of source code must retain the above copyright
9
+   notice, this list of conditions and the following disclaimer.
10
+
11
+2. Redistributions in binary form must reproduce the above copyright
12
+   notice, this list of conditions and the following disclaimer in the
13
+   documentation and/or other materials provided with the
14
+   distribution.
15
+
16
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
17
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
18
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
19
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
20
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
21
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
22
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
23
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
24
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
26
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ 0
- 0
README.md View File


+ 2
- 0
Setup.hs View File

@@ -0,0 +1,2 @@
1
+import Distribution.Simple
2
+main = defaultMain

+ 11
- 0
data/migrations/20171215T321320-hooks.sql View File

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

+ 17
- 0
default.nix View File

@@ -0,0 +1,17 @@
1
+# These arguments are so you can override settings from the command
2
+# line using the `nix-hs' tool.
3
+{ nixpkgs   ? import <nixpkgs> { }
4
+, compiler  ? "default"
5
+, profiling ? false
6
+}:
7
+
8
+let
9
+  pkgs = nixpkgs;
10
+
11
+  buildInputs = with pkgs; [
12
+    # List extra dependencies here.
13
+  ];
14
+
15
+in
16
+  pkgs.nix-hs.interactive ./personal-webhooks.nix
17
+    { inherit compiler profiling buildInputs; }

+ 29
- 0
lib/Web/Hooks/Personal/Action.hs View File

@@ -0,0 +1,29 @@
1
+{-
2
+
3
+This file is part of the package personal-webhooks. It is subject to
4
+the license terms in the LICENSE file found in the top-level directory
5
+of this distribution and at:
6
+
7
+  git://git.devalot.com/personal-webhooks.git
8
+
9
+No part of this package, including this file, may be copied, modified,
10
+propagated, or distributed except according to the terms contained in
11
+the LICENSE file.
12
+
13
+-}
14
+
15
+--------------------------------------------------------------------------------
16
+-- | Actions for responding to HTTP requests.
17
+module Web.Hooks.Personal.Action
18
+  ( Action.Action(..)
19
+  , Action.Status(..)
20
+  , Action.Config(..)
21
+  , Action.statusToHTTP
22
+  , Action.run
23
+  , Action.optionParser
24
+  ) where
25
+
26
+--------------------------------------------------------------------------------
27
+import qualified Web.Hooks.Personal.Action.Config as Action
28
+import qualified Web.Hooks.Personal.Action.Internal as Action
29
+import qualified Web.Hooks.Personal.Action.Options as Action

+ 41
- 0
lib/Web/Hooks/Personal/Action/Config.hs View File

@@ -0,0 +1,41 @@
1
+{-# LANGUAGE OverloadedStrings #-}
2
+
3
+{-
4
+
5
+This file is part of the package personal-webhooks. It is subject to
6
+the license terms in the LICENSE file found in the top-level directory
7
+of this distribution and at:
8
+
9
+  git://git.devalot.com/personal-webhooks.git
10
+
11
+No part of this package, including this file, may be copied, modified,
12
+propagated, or distributed except according to the terms contained in
13
+the LICENSE file.
14
+
15
+-}
16
+
17
+--------------------------------------------------------------------------------
18
+module Web.Hooks.Personal.Action.Config
19
+  ( Config(..)
20
+  ) where
21
+
22
+--------------------------------------------------------------------------------
23
+import Data.Aeson (FromJSON(parseJSON), withObject, (.:?), (.!=))
24
+import Data.Default (Default(def))
25
+
26
+--------------------------------------------------------------------------------
27
+data Config = Config
28
+  { configMaxFileSize :: Integer
29
+    -- ^ Maximum number of bytes to all a file to grow before aborting.
30
+  }
31
+
32
+--------------------------------------------------------------------------------
33
+instance Default Config where
34
+  def = Config
35
+        { configMaxFileSize = 1048576 -- 1MB
36
+        }
37
+
38
+--------------------------------------------------------------------------------
39
+instance FromJSON Config where
40
+  parseJSON = withObject "action config" $ \v ->
41
+    Config <$> v .:? "maxFileSize" .!= configMaxFileSize def

+ 128
- 0
lib/Web/Hooks/Personal/Action/Internal.hs View File

@@ -0,0 +1,128 @@
1
+{-# LANGUAGE DeriveGeneric         #-}
2
+{-# LANGUAGE FlexibleInstances     #-}
3
+{-# LANGUAGE MultiParamTypeClasses #-}
4
+{-# LANGUAGE RecordWildCards       #-}
5
+{-# LANGUAGE ScopedTypeVariables   #-}
6
+{-# LANGUAGE TemplateHaskell       #-}
7
+
8
+{-
9
+
10
+This file is part of the package personal-webhooks. It is subject to
11
+the license terms in the LICENSE file found in the top-level directory
12
+of this distribution and at:
13
+
14
+  git://git.devalot.com/personal-webhooks.git
15
+
16
+No part of this package, including this file, may be copied, modified,
17
+propagated, or distributed except according to the terms contained in
18
+the LICENSE file.
19
+
20
+-}
21
+
22
+--------------------------------------------------------------------------------
23
+-- | Actions that can be performed in response to an HTTP request.
24
+module Web.Hooks.Personal.Action.Internal
25
+  ( Action(..)
26
+  , Status(..)
27
+  , statusToHTTP
28
+  , run
29
+  ) where
30
+
31
+--------------------------------------------------------------------------------
32
+-- Library Imports.
33
+import Control.Exception (SomeException, catch)
34
+import Control.Monad (guard)
35
+import Control.Monad.IO.Class (MonadIO, liftIO)
36
+import Control.Monad.Trans.Maybe (MaybeT(runMaybeT))
37
+import Data.Aeson (ToJSON, FromJSON, encode)
38
+import qualified Data.ByteString.Lazy as LBS
39
+import GHC.Generics (Generic)
40
+import System.Directory (doesFileExist, getFileSize)
41
+import System.IO (IOMode(AppendMode), withFile)
42
+
43
+--------------------------------------------------------------------------------
44
+-- Local Imports.
45
+import Web.Hooks.Personal.Action.Config (Config)
46
+import qualified Web.Hooks.Personal.Action.Config as Config
47
+import Web.Hooks.Personal.Database.Generic (liftJSON)
48
+import Web.Hooks.Personal.Request.Internal
49
+
50
+--------------------------------------------------------------------------------
51
+-- | The different kinds of actions.
52
+data Action = AppendFileAction FilePath
53
+              -- ^ Append incoming data to an existing file.
54
+
55
+            | NoAction
56
+              -- ^ Dummy action.
57
+
58
+              deriving (Show, Generic)
59
+
60
+--------------------------------------------------------------------------------
61
+instance ToJSON Action
62
+instance FromJSON Action
63
+liftJSON ''Action
64
+
65
+--------------------------------------------------------------------------------
66
+-- | Possible responses from running an action.
67
+data Status = Okay    -- ^ Action ran successfully
68
+            | Invalid -- ^ Action can't run due to missing file/info.
69
+            | Fail    -- ^ Action failed.
70
+
71
+--------------------------------------------------------------------------------
72
+-- | Translate a 'Status' into an HTTP status code.
73
+statusToHTTP :: Status -> Int
74
+statusToHTTP Okay    = 204
75
+statusToHTTP Invalid = 501
76
+statusToHTTP Fail    = 500
77
+
78
+--------------------------------------------------------------------------------
79
+-- | Run an action.
80
+run :: (MonadIO m)
81
+    => Config
82
+    -- ^ Action configuration.
83
+
84
+    -> Request
85
+    -- ^ Incoming data.
86
+
87
+    -> Action
88
+    -- ^ The action to run.
89
+
90
+    -> m Status
91
+    -- ^ Result status.
92
+
93
+run Config.Config{..} (Request v) a = do
94
+  result <- liftIO $ catch (runMaybeT action)
95
+                           (\(_ :: SomeException) -> return $ Just Fail)
96
+
97
+  case result of
98
+    Nothing -> return Invalid
99
+    Just r  -> return r
100
+
101
+  where
102
+    action :: MaybeT IO Status
103
+    action =
104
+      case a of
105
+        AppendFileAction f -> append f
106
+        NoAction           -> return Okay
107
+        -- Room to grow...
108
+
109
+    append :: FilePath -> MaybeT IO Status
110
+    append file = do
111
+      -- Verify the file exists.
112
+      exists <- liftIO (doesFileExist file)
113
+      guard exists
114
+
115
+      -- Ensure it won't grow bigger than allowed.
116
+      let bs = encode v
117
+          bsize = toInteger (LBS.length bs)
118
+
119
+      size <- liftIO (getFileSize file)
120
+      guard (size + bsize <= configMaxFileSize)
121
+
122
+      -- Safe to append now.
123
+      remaining <- liftIO $ withFile file AppendMode (`LBS.hPutNonBlocking` bs)
124
+
125
+      -- Test to see if all data was written.
126
+      if LBS.null remaining
127
+         then return Okay
128
+         else return Fail

+ 42
- 0
lib/Web/Hooks/Personal/Action/Options.hs View File

@@ -0,0 +1,42 @@
1
+{-
2
+
3
+This file is part of the package personal-webhooks. It is subject to
4
+the license terms in the LICENSE file found in the top-level directory
5
+of this distribution and at:
6
+
7
+  git://git.devalot.com/personal-webhooks.git
8
+
9
+No part of this package, including this file, may be copied, modified,
10
+propagated, or distributed except according to the terms contained in
11
+the LICENSE file.
12
+
13
+-}
14
+
15
+--------------------------------------------------------------------------------
16
+-- | Command line option parser for 'Action'.
17
+module Web.Hooks.Personal.Action.Options
18
+  ( optionParser
19
+  ) where
20
+
21
+--------------------------------------------------------------------------------
22
+-- Library Imports:
23
+import Options.Applicative
24
+
25
+--------------------------------------------------------------------------------
26
+-- Local Imports:
27
+import Web.Hooks.Personal.Action.Internal (Action(..))
28
+
29
+--------------------------------------------------------------------------------
30
+-- | Parse an 'Action' from the command line.
31
+optionParser :: Parser Action
32
+optionParser = appendFileAction
33
+
34
+--------------------------------------------------------------------------------
35
+-- | Parse an 'AppendFileAction' from the command line.
36
+appendFileAction :: Parser Action
37
+appendFileAction =
38
+  AppendFileAction
39
+    <$> option str (mconcat [ long "append"
40
+                            , metavar "FILE"
41
+                            , help "Append the HTTP request to FILE"
42
+                            ])

+ 27
- 0
lib/Web/Hooks/Personal/Database.hs View File

@@ -0,0 +1,27 @@
1
+{-
2
+
3
+This file is part of the package personal-webhooks. It is subject to
4
+the license terms in the LICENSE file found in the top-level directory
5
+of this distribution and at:
6
+
7
+  git://git.devalot.com/personal-webhooks.git
8
+
9
+No part of this package, including this file, may be copied, modified,
10
+propagated, or distributed except according to the terms contained in
11
+the LICENSE file.
12
+
13
+-}
14
+
15
+--------------------------------------------------------------------------------
16
+module Web.Hooks.Personal.Database
17
+  ( Database.Database
18
+  , Database.Config(..)
19
+  , Database.database
20
+  , Database.runQuery
21
+  , Database.runInsert
22
+  , Database.migrate
23
+  ) where
24
+
25
+--------------------------------------------------------------------------------
26
+import qualified Web.Hooks.Personal.Database.Config as Database
27
+import qualified Web.Hooks.Personal.Database.Internal as Database

+ 47
- 0
lib/Web/Hooks/Personal/Database/Config.hs View File

@@ -0,0 +1,47 @@
1
+{-# LANGUAGE OverloadedStrings #-}
2
+
3
+{-
4
+
5
+This file is part of the package personal-webhooks. It is subject to
6
+the license terms in the LICENSE file found in the top-level directory
7
+of this distribution and at:
8
+
9
+  git://git.devalot.com/personal-webhooks.git
10
+
11
+No part of this package, including this file, may be copied, modified,
12
+propagated, or distributed except according to the terms contained in
13
+the LICENSE file.
14
+
15
+-}
16
+
17
+--------------------------------------------------------------------------------
18
+module Web.Hooks.Personal.Database.Config
19
+  ( Config(..)
20
+  ) where
21
+
22
+--------------------------------------------------------------------------------
23
+import Data.Aeson (FromJSON(parseJSON), withObject, (.:?), (.!=))
24
+import Data.Default (Default(def))
25
+import Data.Text (Text)
26
+
27
+--------------------------------------------------------------------------------
28
+data Config = Config
29
+  { configConnectionString :: Text
30
+    -- ^ libpq connection string.
31
+
32
+  , configPoolSize :: Int
33
+    -- ^ Size of the database connection pool.
34
+  }
35
+
36
+--------------------------------------------------------------------------------
37
+instance Default Config where
38
+  def = Config
39
+        { configConnectionString = "user=webhooks dbname=webhooks password=webhooks"
40
+        , configPoolSize = 5
41
+        }
42
+
43
+--------------------------------------------------------------------------------
44
+instance FromJSON Config where
45
+  parseJSON = withObject "database config" $ \v ->
46
+    Config <$> v .:? "connection" .!= configConnectionString def
47
+           <*> v .:? "poolSize"   .!= configPoolSize def

+ 29
- 0
lib/Web/Hooks/Personal/Database/Functions.hs View File

@@ -0,0 +1,29 @@
1
+{-
2
+
3
+This file is part of the package personal-webhooks. It is subject to
4
+the license terms in the LICENSE file found in the top-level directory
5
+of this distribution and at:
6
+
7
+  git://git.devalot.com/personal-webhooks.git
8
+
9
+No part of this package, including this file, may be copied, modified,
10
+propagated, or distributed except according to the terms contained in
11
+the LICENSE file.
12
+
13
+-}
14
+
15
+--------------------------------------------------------------------------------
16
+-- | Access to PostgreSQL functions.
17
+module Web.Hooks.Personal.Database.Functions
18
+  ( now
19
+  ) where
20
+
21
+--------------------------------------------------------------------------------
22
+import Opaleye.Internal.Column (Column(..))
23
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
24
+import Opaleye.PGTypes
25
+
26
+--------------------------------------------------------------------------------
27
+-- | Current transaction time.
28
+now :: Column PGTimestamptz
29
+now = Column (HPQ.FunExpr "now" [])

+ 70
- 0
lib/Web/Hooks/Personal/Database/Generic.hs View File

@@ -0,0 +1,70 @@
1
+{-# LANGUAGE FlexibleInstances     #-}
2
+{-# LANGUAGE MultiParamTypeClasses #-}
3
+{-# LANGUAGE TemplateHaskell       #-}
4
+
5
+{-
6
+
7
+This file is part of the package personal-webhooks. It is subject to
8
+the license terms in the LICENSE file found in the top-level directory
9
+of this distribution and at:
10
+
11
+  git://git.devalot.com/personal-webhooks.git
12
+
13
+No part of this package, including this file, may be copied, modified,
14
+propagated, or distributed except according to the terms contained in
15
+the LICENSE file.
16
+
17
+-}
18
+
19
+--------------------------------------------------------------------------------
20
+-- | Use generic PostgreSQL columns to hold Haskell types.
21
+module Web.Hooks.Personal.Database.Generic
22
+  ( LiftJSON(..)
23
+  , liftJSON
24
+  ) where
25
+
26
+--------------------------------------------------------------------------------
27
+-- Library Imports:
28
+import Data.Aeson (ToJSON, FromJSON)
29
+import qualified Data.Aeson as Aeson
30
+import Data.Profunctor.Product.Default (Default(def))
31
+import Data.Typeable (Typeable)
32
+import Database.PostgreSQL.Simple.FromField (FromField(..), Conversion, ResultError(..), returnError)
33
+import qualified Language.Haskell.TH as TH
34
+import Opaleye
35
+
36
+--------------------------------------------------------------------------------
37
+-- | A type wrapper to lift another type into PostgreSQL via @PGJson@.
38
+newtype LiftJSON a = LiftJSON { unliftJSON :: a }
39
+
40
+--------------------------------------------------------------------------------
41
+instance (FromJSON a, Typeable a) => FromField (LiftJSON a) where
42
+  fromField f b = go =<< fromField f b
43
+    where
44
+      go :: (FromJSON a, Typeable a) => Aeson.Value -> Conversion (LiftJSON a)
45
+      go v = case Aeson.fromJSON v of
46
+               Aeson.Success x -> return (LiftJSON x)
47
+               Aeson.Error e   -> returnError ConversionFailed f e
48
+
49
+--------------------------------------------------------------------------------
50
+instance (FromJSON a, Typeable a) => QueryRunnerColumnDefault PGJson (LiftJSON a) where
51
+  queryRunnerColumnDefault = fieldQueryRunnerColumn
52
+
53
+--------------------------------------------------------------------------------
54
+instance (ToJSON a) => Default Constant (LiftJSON a) (Column PGJson) where
55
+  def = Constant (pgValueJSON . Aeson.toJSON . unliftJSON)
56
+
57
+--------------------------------------------------------------------------------
58
+-- | Use Template Haskell to generate database instances for @PGJson@.
59
+liftJSON :: TH.Name -> TH.Q [TH.Dec]
60
+liftJSON name =
61
+  [d|
62
+    instance FromField $(TH.conT name) where
63
+      fromField f b = unliftJSON <$> fromField f b
64
+
65
+    instance QueryRunnerColumnDefault PGJson $(TH.conT name) where
66
+      queryRunnerColumnDefault = unliftJSON <$> queryRunnerColumnDefault
67
+
68
+    instance Default Constant $(TH.conT name) (Column PGJson) where
69
+      def = Constant (pgValueJSON . Aeson.toJSON)
70
+  |]

+ 131
- 0
lib/Web/Hooks/Personal/Database/Internal.hs View File

@@ -0,0 +1,131 @@
1
+{-# LANGUAGE FlexibleContexts #-}
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 Web.Hooks.Personal.Database.Internal
20
+  ( Database
21
+  , database
22
+  , runQuery
23
+  , runInsert
24
+  , migrate
25
+  ) where
26
+
27
+--------------------------------------------------------------------------------
28
+-- Library Imports:
29
+import Control.Monad.IO.Class (MonadIO, liftIO)
30
+import Data.Int (Int64)
31
+import Data.Pool (Pool)
32
+import qualified Data.Pool as Pool
33
+import Data.Profunctor.Product.Default (Default)
34
+import qualified Data.Text.Encoding as Text
35
+import Database.PostgreSQL.Simple (Connection)
36
+import qualified Database.PostgreSQL.Simple as PostgreSQL
37
+import qualified Opaleye
38
+import System.Exit (die)
39
+import System.FilePath ((</>))
40
+
41
+--------------------------------------------------------------------------------
42
+-- For database migrations:
43
+import Database.PostgreSQL.Simple.Util (existsTable)
44
+import Database.PostgreSQL.Simple.Migration ( MigrationCommand(..)
45
+                                            , MigrationResult(..)
46
+                                            , runMigrations
47
+                                            )
48
+
49
+--------------------------------------------------------------------------------
50
+-- Local Imports:
51
+import Paths_personal_webhooks (getDataDir)
52
+import Web.Hooks.Personal.Database.Config
53
+
54
+--------------------------------------------------------------------------------
55
+-- | A database handle.
56
+data Database = Database
57
+  { dbPool :: Pool Connection
58
+  }
59
+
60
+--------------------------------------------------------------------------------
61
+-- | Given a configuration object, create a database handle.
62
+database :: (MonadIO m) => Config -> m Database
63
+database Config{..} = do
64
+    pool <- liftIO (Pool.createPool connect close 1 timeout configPoolSize)
65
+    return (Database pool)
66
+  where
67
+    constr  = Text.encodeUtf8 configConnectionString
68
+    connect = PostgreSQL.connectPostgreSQL constr
69
+    close   = PostgreSQL.close
70
+    timeout = 30
71
+
72
+--------------------------------------------------------------------------------
73
+-- | Internal function to get a connection out of the pool.
74
+withConnection :: (MonadIO m) => Database -> (Connection -> IO a) -> m a
75
+withConnection Database{..} = liftIO . Pool.withResource dbPool
76
+
77
+--------------------------------------------------------------------------------
78
+-- | Run an Opaleye query (SELECT).
79
+runQuery :: (MonadIO m, Default Opaleye.QueryRunner cs h)
80
+         => Database
81
+         -- ^ A 'Database' object.
82
+
83
+         -> Opaleye.Query cs
84
+         -- ^ The query you want to execute.
85
+
86
+         -> m [h]
87
+         -- ^ Query results, converted into the correct type.
88
+
89
+runQuery d q = withConnection d $ \c -> Opaleye.runQuery c q
90
+
91
+--------------------------------------------------------------------------------
92
+-- | Run an Opaleye insert.
93
+runInsert :: (MonadIO m, Default Opaleye.Constant h cs)
94
+          => Database
95
+          -- ^ A 'Database' object.
96
+
97
+          -> Opaleye.Table cs cs'
98
+          -- ^ The table to insert into.
99
+
100
+          -> [h]
101
+          -- ^ List of values to insert.  These will automatically be
102
+          -- converted into the appropriate PostgreSQL columns types.
103
+
104
+          -> m Int64
105
+          -- ^ Number of rows inserted.
106
+
107
+runInsert d t hs =
108
+  withConnection d $ \c ->
109
+    Opaleye.runInsertMany c t (map Opaleye.constant hs)
110
+
111
+--------------------------------------------------------------------------------
112
+-- | Run the database migrations.  Exits the current process if there
113
+-- is an error running the migrations.
114
+migrate :: (MonadIO m) => Database -> Bool -> m ()
115
+migrate d verbose = withConnection d go
116
+  where
117
+    go :: Connection -> IO ()
118
+    go c = do
119
+      inited  <- existsTable c "schema_migrations"
120
+      datadir <- liftIO getDataDir
121
+
122
+      let dir = datadir </> "data" </> "migrations"
123
+          mi  = if inited then [] else [MigrationInitialization]
124
+          ms  = mi ++ [MigrationDirectory dir]
125
+
126
+      result <- PostgreSQL.withTransaction c $
127
+                  runMigrations verbose c ms
128
+
129
+      case result of
130
+        MigrationSuccess -> return ()
131
+        MigrationError e -> die e

+ 29
- 0
lib/Web/Hooks/Personal/Hook.hs View File

@@ -0,0 +1,29 @@
1
+{-
2
+
3
+This file is part of the package personal-webhooks. It is subject to
4
+the license terms in the LICENSE file found in the top-level directory
5
+of this distribution and at:
6
+
7
+  git://git.devalot.com/personal-webhooks.git
8
+
9
+No part of this package, including this file, may be copied, modified,
10
+propagated, or distributed except according to the terms contained in
11
+the LICENSE file.
12
+
13
+-}
14
+
15
+--------------------------------------------------------------------------------
16
+-- | Hook type and functions.
17
+module Web.Hooks.Personal.Hook
18
+  ( Hook.Hook
19
+  , Hook.HookNotSaved
20
+  , Hook.Hook'(..)
21
+  , Hook.hook
22
+  , Hook.table
23
+  , Hook.all
24
+  , Hook.find
25
+  ) where
26
+
27
+--------------------------------------------------------------------------------
28
+import qualified Web.Hooks.Personal.Hook.Database as Hook
29
+import qualified Web.Hooks.Personal.Hook.Internal as Hook

+ 62
- 0
lib/Web/Hooks/Personal/Hook/Database.hs View File

@@ -0,0 +1,62 @@
1
+{-# LANGUAGE Arrows #-}
2
+
3
+{-
4
+
5
+This file is part of the package personal-webhooks. It is subject to
6
+the license terms in the LICENSE file found in the top-level directory
7
+of this distribution and at:
8
+
9
+  git://git.devalot.com/personal-webhooks.git
10
+
11
+No part of this package, including this file, may be copied, modified,
12
+propagated, or distributed except according to the terms contained in
13
+the LICENSE file.
14
+
15
+-}
16
+
17
+--------------------------------------------------------------------------------
18
+module Web.Hooks.Personal.Hook.Database
19
+  ( table
20
+  , all
21
+  , find
22
+  ) where
23
+
24
+--------------------------------------------------------------------------------
25
+-- Library Imports:
26
+import Control.Arrow (returnA)
27
+import Data.Text (Text)
28
+import Opaleye
29
+import Prelude hiding (all)
30
+
31
+--------------------------------------------------------------------------------
32
+-- Local Imports:
33
+import Web.Hooks.Personal.Database.Functions (now)
34
+import Web.Hooks.Personal.Hook.Internal
35
+
36
+--------------------------------------------------------------------------------
37
+-- | Opaleye defintion for the hooks table.
38
+table :: Table HookW HookR
39
+table = Table "hooks"
40
+  (pHook Hook { hookID             = optional "id"
41
+              , hookCode           = required "code"
42
+              , hookExpirationTime = required "expires_at"
43
+              , hookAction         = required "action"
44
+              })
45
+
46
+--------------------------------------------------------------------------------
47
+-- | Fetch all hooks.
48
+all :: Query HookR
49
+all = queryTable table
50
+
51
+--------------------------------------------------------------------------------
52
+-- | Find a hook based on its secret code.
53
+find :: Text -> Query HookR
54
+find code = proc () -> do
55
+    row <- queryTable table -< ()
56
+    restrict -< hookCode row .== pgStrictText code
57
+    restrict -< isNull (hookExpirationTime row) .|| notExpired row
58
+    returnA  -< row
59
+
60
+  where
61
+    notExpired :: HookR -> Column PGBool
62
+    notExpired row = fromNullable now (hookExpirationTime row) .< now

+ 114
- 0
lib/Web/Hooks/Personal/Hook/Internal.hs View File

@@ -0,0 +1,114 @@
1
+{-# LANGUAGE DeriveGeneric         #-}
2
+{-# LANGUAGE FlexibleInstances     #-}
3
+{-# LANGUAGE MultiParamTypeClasses #-}
4
+{-# LANGUAGE RecordWildCards       #-}
5
+{-# LANGUAGE TemplateHaskell       #-}
6
+
7
+{-
8
+
9
+This file is part of the package personal-webhooks. It is subject to
10
+the license terms in the LICENSE file found in the top-level directory
11
+of this distribution and at:
12
+
13
+  git://git.devalot.com/personal-webhooks.git
14
+
15
+No part of this package, including this file, may be copied, modified,
16
+propagated, or distributed except according to the terms contained in
17
+the LICENSE file.
18
+
19
+-}
20
+
21
+--------------------------------------------------------------------------------
22
+-- | Information about how to handle an HTTP request.
23
+module Web.Hooks.Personal.Hook.Internal
24
+  ( Hook
25
+  , HookNotSaved
26
+  , Hook'(..)
27
+  , HookR
28
+  , HookW
29
+  , pHook
30
+  , hook
31
+  ) where
32
+
33
+--------------------------------------------------------------------------------
34
+-- Library Imports.
35
+import qualified Codec.Binary.Base64Url as Base64
36
+import Control.Monad.IO.Class (MonadIO, liftIO)
37
+import Crypto.Random (randomBytesGenerate, drgNewSeed, seedNew)
38
+import Data.Aeson (ToJSON, FromJSON)
39
+import Data.Int (Int64)
40
+import Data.Profunctor.Product.Default (Default(def))
41
+import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
42
+import Data.Text (Text)
43
+import qualified Data.Text.Encoding as Text
44
+import Data.Time (UTCTime)
45
+import GHC.Generics (Generic)
46
+import Opaleye (Column, Nullable, Constant(..), constant)
47
+import Opaleye.PGTypes
48
+
49
+--------------------------------------------------------------------------------
50
+-- Local Imports.
51
+import Web.Hooks.Personal.Action.Internal (Action)
52
+
53
+--------------------------------------------------------------------------------
54
+-- | Type alias to make the @Hook'@ type concrete.
55
+type HookNotSaved = Hook' (Maybe Int64) Text (Maybe UTCTime) Action
56
+type Hook         = Hook' Int64 Text (Maybe UTCTime) Action
57
+
58
+--------------------------------------------------------------------------------
59
+-- | Polymorphic hook suitable for storing in a database.
60
+data Hook' key text time action = Hook
61
+  { hookID :: key
62
+    -- ^ Database ID.
63
+
64
+  , hookCode :: text
65
+    -- ^ Secret code.
66
+
67
+  , hookExpirationTime :: time
68
+    -- ^ Optional expiration time for the hook.
69
+
70
+  , hookAction :: action
71
+    -- ^ The action to run for this hook.
72
+  } deriving (Generic, Show)
73
+
74
+--------------------------------------------------------------------------------
75
+instance ToJSON Hook
76
+instance FromJSON Hook
77
+
78
+--------------------------------------------------------------------------------
79
+-- | Create profunctor-product instances for Opaleye.
80
+$(makeAdaptorAndInstance "pHook" ''Hook')
81
+
82
+--------------------------------------------------------------------------------
83
+-- | Concrete hook type for reading columns from the database.
84
+type HookR = Hook' (Column PGInt8)                   -- ID
85
+                   (Column PGText)                   -- Code
86
+                   (Column (Nullable PGTimestamptz)) -- Expiration date.
87
+                   (Column PGJson)                   -- Action (encoded as JSON)
88
+
89
+--------------------------------------------------------------------------------
90
+-- | Concrete hook type for writing columns to the database.
91
+type HookW = Hook' (Maybe (Column PGInt8))           -- Auto increment ID.
92
+                   (Column PGText)                   -- Code
93
+                   (Column (Nullable PGTimestamptz)) -- Expiration date.
94
+                   (Column PGJson)                   -- Action (encoded as JSON)
95
+
96
+--------------------------------------------------------------------------------
97
+instance Default Constant Hook ( Maybe (Column PGInt8)
98
+                               , Column PGText
99
+                               , Column (Nullable PGTimestamptz)
100
+                               , Column PGJson
101
+                               ) where
102
+  def = Constant $ \Hook{..} -> ( Nothing
103
+                                , constant hookCode
104
+                                , constant hookExpirationTime
105
+                                , constant hookAction
106
+                                )
107
+
108
+--------------------------------------------------------------------------------
109
+-- | Helper function to construct a hook with a unique @hookCode@.
110
+hook :: (MonadIO m) => Maybe UTCTime -> Action -> m HookNotSaved
111
+hook time action = do
112
+    bytes <- liftIO (fst . randomBytesGenerate 48 . drgNewSeed <$> seedNew)
113
+    let code = Text.decodeUtf8 (Base64.encode bytes)
114
+    return (Hook Nothing code time action)

+ 25
- 0
lib/Web/Hooks/Personal/Request.hs View File

@@ -0,0 +1,25 @@
1
+{-
2
+
3
+This file is part of the package personal-webhooks. It is subject to
4
+the license terms in the LICENSE file found in the top-level directory
5
+of this distribution and at:
6
+
7
+  git://git.devalot.com/personal-webhooks.git
8
+
9
+No part of this package, including this file, may be copied, modified,
10
+propagated, or distributed except according to the terms contained in
11
+the LICENSE file.
12
+
13
+-}
14
+--------------------------------------------------------------------------------
15
+-- | Request data to pass along to a hook action.
16
+module Web.Hooks.Personal.Request
17
+  ( Request.Request
18
+  , Request.fromJSON
19
+  , Request.fromParams
20
+  , Request.Config(..)
21
+  ) where
22
+
23
+--------------------------------------------------------------------------------
24
+import qualified Web.Hooks.Personal.Request.Config as Request
25
+import qualified Web.Hooks.Personal.Request.Internal as Request

+ 41
- 0
lib/Web/Hooks/Personal/Request/Config.hs View File

@@ -0,0 +1,41 @@
1
+{-# LANGUAGE OverloadedStrings #-}
2
+
3
+{-
4
+
5
+This file is part of the package personal-webhooks. It is subject to
6
+the license terms in the LICENSE file found in the top-level directory
7
+of this distribution and at:
8
+
9
+  git://git.devalot.com/personal-webhooks.git
10
+
11
+No part of this package, including this file, may be copied, modified,
12
+propagated, or distributed except according to the terms contained in
13
+the LICENSE file.
14
+
15
+-}
16
+
17
+--------------------------------------------------------------------------------
18
+module Web.Hooks.Personal.Request.Config
19
+  ( Config(..)
20
+  ) where
21
+
22
+--------------------------------------------------------------------------------
23
+import Data.Aeson (FromJSON(parseJSON), withObject, (.:?), (.!=))
24
+import Data.Default (Default(def))
25
+
26
+--------------------------------------------------------------------------------
27
+data Config = Config
28
+  { configMaxBodySize :: Int
29
+    -- ^ Maximum number of bytes to read from an HTTP body.
30
+  }
31
+
32
+--------------------------------------------------------------------------------
33
+instance Default Config where
34
+  def = Config
35
+        { configMaxBodySize = 2048 -- 2k
36
+        }
37
+
38
+--------------------------------------------------------------------------------
39
+instance FromJSON Config where
40
+  parseJSON = withObject "request config" $ \v ->
41
+    Config <$> v .:? "maxBodySize" .!= configMaxBodySize def

+ 49
- 0
lib/Web/Hooks/Personal/Request/Internal.hs View File

@@ -0,0 +1,49 @@
1
+{-
2
+
3
+This file is part of the package personal-webhooks. It is subject to
4
+the license terms in the LICENSE file found in the top-level directory
5
+of this distribution and at:
6
+
7
+  git://git.devalot.com/personal-webhooks.git
8
+
9
+No part of this package, including this file, may be copied, modified,
10
+propagated, or distributed except according to the terms contained in
11
+the LICENSE file.
12
+
13
+-}
14
+
15
+--------------------------------------------------------------------------------
16
+-- | Internal implementation of the 'Request' type and functions.
17
+module Web.Hooks.Personal.Request.Internal
18
+  ( Request(..)
19
+  , fromJSON
20
+  , fromParams
21
+  ) where
22
+
23
+--------------------------------------------------------------------------------
24
+-- Library Imports:
25
+import qualified Data.Aeson as Aeson
26
+import qualified Data.ByteString as B
27
+import qualified Data.ByteString.Lazy as L
28
+import Data.Map.Lazy (Map)
29
+import qualified Data.Map.Lazy as Map
30
+import Data.Text (Text)
31
+import qualified Data.Text.Encoding as Text
32
+
33
+--------------------------------------------------------------------------------
34
+-- | A type to represent an HTTP request.
35
+newtype Request = Request Aeson.Value
36
+
37
+--------------------------------------------------------------------------------
38
+-- | Create a 'Request' from a string containing JSON data.
39
+fromJSON :: L.ByteString -> Maybe Request
40
+fromJSON = fmap Request . Aeson.decode
41
+
42
+--------------------------------------------------------------------------------
43
+-- | Create a 'Request' from decoded query parameters.
44
+fromParams :: Map B.ByteString [B.ByteString] -> Maybe Request
45
+fromParams =
46
+    Just . Request . Aeson.toJSON . Map.fromList . map convert . Map.toList
47
+  where
48
+    convert :: (B.ByteString, [B.ByteString]) -> (Text, [Text])
49
+    convert (k, vs) = (Text.decodeUtf8 k, map Text.decodeUtf8 vs)

+ 105
- 0
personal-webhooks.cabal View File

@@ -0,0 +1,105 @@
1
+name:          personal-webhooks
2
+version:       0.1.0.0
3
+synopsis:      Trigger personal scripts from incoming HTTP requests
4
+license:       BSD2
5
+license-file:  LICENSE
6
+author:        Peter Jones <pjones@devalot.com>
7
+maintainer:    Peter Jones <pjones@devalot.com>
8
+copyright:     Copyright (c) 2017 Peter J. Jones
9
+category:      Web
10
+build-type:    Simple
11
+cabal-version: >=1.10
12
+-- description:         
13
+
14
+--------------------------------------------------------------------------------
15
+extra-source-files:
16
+  README.md
17
+  CHANGES.md
18
+
19
+--------------------------------------------------------------------------------
20
+-- Files needed at run time.
21
+data-files:
22
+  data/migrations/*.sql        
23
+
24
+--------------------------------------------------------------------------------
25
+source-repository head
26
+  type: git
27
+  location: git://github.com/pjones/personal-webhooks.git
28
+
29
+--------------------------------------------------------------------------------
30
+flag maintainer
31
+  description: Enable settings for the package maintainer.
32
+  manual: True
33
+  default: False
34
+
35
+--------------------------------------------------------------------------------
36
+library
37
+  exposed-modules:     
38
+    Web.Hooks.Personal.Action
39
+      Web.Hooks.Personal.Action.Config
40
+      Web.Hooks.Personal.Action.Internal
41
+      Web.Hooks.Personal.Action.Options
42
+    Web.Hooks.Personal.Database
43
+      Web.Hooks.Personal.Database.Config
44
+      Web.Hooks.Personal.Database.Functions
45
+      Web.Hooks.Personal.Database.Generic
46
+      Web.Hooks.Personal.Database.Internal
47
+    Web.Hooks.Personal.Hook
48
+      Web.Hooks.Personal.Hook.Database
49
+      Web.Hooks.Personal.Hook.Internal  
50
+    Web.Hooks.Personal.Request
51
+      Web.Hooks.Personal.Request.Config
52
+      Web.Hooks.Personal.Request.Internal
53
+    
54
+  other-modules:
55
+    Paths_personal_webhooks
56
+
57
+  hs-source-dirs: lib
58
+  default-language: Haskell2010
59
+  ghc-options: -Wall -fwarn-incomplete-uni-patterns -Wincomplete-record-updates
60
+
61
+  if flag(maintainer)
62
+    ghc-options: -Werror
63
+
64
+  build-depends: base                        >= 4.9  && < 5
65
+               , aeson                       >= 1.1  && < 1.3
66
+               , bytestring                  >= 0.10 && < 0.11
67
+               , containers                  >= 0.5  && < 0.6
68
+               , cryptonite                  >= 0.23 && < 0.24
69
+               , data-default                >= 0.7  && < 1.0
70
+               , directory                   >= 1.3  && < 1.4
71
+               , filepath                    >= 1.4  && < 1.5
72
+               , opaleye                     >= 0.5  && < 0.7
73
+               , optparse-applicative        >= 0.13 && < 0.15
74
+               , postgresql-simple           >= 0.5  && < 0.6
75
+               , postgresql-simple-migration >= 0.1  && < 0.2
76
+               , product-profunctors         >= 0.8  && < 0.9
77
+               , profunctors                 >= 5.2  && < 5.3
78
+               , resource-pool               >= 0.2  && < 0.3
79
+               , sandi                       >= 0.4  && < 0.5
80
+               , template-haskell            >= 2.11 && < 2.12
81
+               , text                        >= 1.2  && < 1.3
82
+               , time                        >= 1.6  && < 1.9
83
+               , transformers                >= 0.5  && < 1.0
84
+
85
+--------------------------------------------------------------------------------
86
+executable webhooks
87
+  other-modules:
88
+    UI.Create
89
+    UI.List
90
+           
91
+  hs-source-dirs: src
92
+  main-is: Main.hs
93
+  default-language: Haskell2010
94
+
95
+  build-depends: base
96
+               , aeson
97
+               , bytestring
98
+               , data-default
99
+               , optparse-applicative
100
+               , personal-webhooks
101
+               , table-layout >= 0.8 && < 0.9
102
+               , text
103
+
104
+  if flag(maintainer)
105
+    ghc-options: -Werror

+ 26
- 0
personal-webhooks.nix View File

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

+ 10
- 0
scripts/devrun.sh View File

@@ -0,0 +1,10 @@
1
+#!/bin/sh
2
+
3
+################################################################################
4
+# Wrapper around the webhooks executable that points it at the correct
5
+# data-dir so it can find its migrations and other necessary files.
6
+set -e
7
+
8
+################################################################################
9
+export personal_webhooks_datadir=$(pwd)
10
+dist/build/webhooks/webhooks "$@"

+ 9
- 0
scripts/new-migration.sh View File

@@ -0,0 +1,9 @@
1
+#!/bin/sh
2
+
3
+################################################################################
4
+set -e
5
+
6
+################################################################################
7
+name=$(date +%Y%m%dT%M%H%S)-"$1".sql
8
+touch data/migrations/"$name"
9
+echo "$name"

+ 74
- 0
src/Main.hs View File

@@ -0,0 +1,74 @@
1
+{-# LANGUAGE OverloadedStrings #-}
2
+
3
+{-
4
+
5
+This file is part of the package personal-webhooks. It is subject to
6
+the license terms in the LICENSE file found in the top-level directory
7
+of this distribution and at:
8
+
9
+  git://git.devalot.com/personal-webhooks.git
10
+
11
+No part of this package, including this file, may be copied, modified,
12
+propagated, or distributed except according to the terms contained in
13
+the LICENSE file.
14
+
15
+-}
16
+
17
+--------------------------------------------------------------------------------
18
+module Main (main) where
19
+
20
+--------------------------------------------------------------------------------
21
+-- Library Imports:
22
+import Data.Default (def)
23
+import Options.Applicative
24
+
25
+--------------------------------------------------------------------------------
26
+-- Local Imports:
27
+import qualified UI.Create as Create
28
+import qualified UI.List as List
29
+import qualified Web.Hooks.Personal.Database as Database
30
+
31
+--------------------------------------------------------------------------------
32
+-- | Subcommand.
33
+data Command = Create Create.Options -- ^ Create a new hook.
34
+             | List List.Options     -- ^ List hooks.
35
+
36
+--------------------------------------------------------------------------------
37
+-- | Command line options
38
+data Options = Options
39
+  { optionCommand :: Command
40
+    -- ^ Which subcommand to run.
41
+  }
42
+
43
+--------------------------------------------------------------------------------
44
+-- | Command line option parser.
45
+parser :: Parser Options
46
+parser =
47
+  Options
48
+    <$> subparser (mconcat [ createCommand
49
+                           , listCommand
50
+                           ])
51
+
52
+  where
53
+    mkCmd :: String -> String -> Parser a -> Mod CommandFields a
54
+    mkCmd name desc p =
55
+      command name (info (p <**> helper) (progDesc desc))
56
+
57
+    createCommand =
58
+      mkCmd "create" "Create a new webhook" (Create <$> Create.parser)
59
+
60
+    listCommand =
61
+      mkCmd "list" "List hooks" (List <$> List.parser)
62
+
63
+--------------------------------------------------------------------------------
64
+-- | Main entry point.
65
+main :: IO ()
66
+main = do
67
+  options <- execParser $ info (parser <**> helper) idm
68
+
69
+  database <- Database.database def
70
+  Database.migrate database False
71
+
72
+  case optionCommand options of
73
+    Create o -> Create.run o database
74
+    List o   -> List.run o database

+ 53
- 0
src/UI/Create.hs View File

@@ -0,0 +1,53 @@
1
+{-# LANGUAGE RecordWildCards #-}
2
+
3
+{-
4
+
5
+This file is part of the package personal-webhooks. It is subject to
6
+the license terms in the LICENSE file found in the top-level directory
7
+of this distribution and at:
8
+
9
+  git://git.devalot.com/personal-webhooks.git
10
+
11
+No part of this package, including this file, may be copied, modified,
12
+propagated, or distributed except according to the terms contained in
13
+the LICENSE file.
14
+
15
+-}
16
+
17
+--------------------------------------------------------------------------------
18
+module UI.Create
19
+  ( Options
20
+  , parser
21
+  , run
22
+  ) where
23
+
24
+--------------------------------------------------------------------------------
25
+-- Library Imports:
26
+import qualified Data.Text as Text
27
+import Options.Applicative
28
+
29
+--------------------------------------------------------------------------------
30
+-- Local Imports:
31
+import qualified Web.Hooks.Personal.Action as Action
32
+import Web.Hooks.Personal.Database (Database)
33
+import qualified Web.Hooks.Personal.Database as Database
34
+import qualified Web.Hooks.Personal.Hook as Hook
35
+
36
+--------------------------------------------------------------------------------
37
+-- | Options needed to create a new hook.
38
+data Options = Options
39
+  { optionAction :: Action.Action
40
+  }
41
+
42
+--------------------------------------------------------------------------------
43
+-- | Parse command line options for creating a new hook.
44
+parser :: Parser Options
45
+parser = Options <$> Action.optionParser
46
+
47
+--------------------------------------------------------------------------------
48
+-- | Run the @create@ command to create a new webhook.
49
+run :: Options -> Database -> IO ()
50
+run Options{..} db = do
51
+  h <- Hook.hook Nothing optionAction
52
+  _ <- Database.runInsert db Hook.table [h]
53
+  putStrLn ("New hook code: " ++ Text.unpack (Hook.hookCode h))

+ 90
- 0
src/UI/List.hs View File

@@ -0,0 +1,90 @@
1
+{-# LANGUAGE RecordWildCards #-}
2
+
3
+{-
4
+
5
+This file is part of the package personal-webhooks. It is subject to
6
+the license terms in the LICENSE file found in the top-level directory
7
+of this distribution and at:
8
+
9
+  git://git.devalot.com/personal-webhooks.git
10
+
11
+No part of this package, including this file, may be copied, modified,
12
+propagated, or distributed except according to the terms contained in
13
+the LICENSE file.
14
+
15
+-}
16
+
17
+--------------------------------------------------------------------------------
18
+module UI.List
19
+  ( Options
20
+  , parser
21
+  , run
22
+  ) where
23
+
24
+--------------------------------------------------------------------------------
25
+-- Library Imports:
26
+import Control.Monad (forM_)
27
+import qualified Data.Aeson as Aeson
28
+import qualified Data.ByteString.Lazy.Char8 as LBS
29
+import Data.Default (def)
30
+import qualified Data.Text as Text
31
+import Options.Applicative
32
+import qualified Text.Layout.Table as Table
33
+
34
+--------------------------------------------------------------------------------
35
+-- Local Imports:
36
+import Web.Hooks.Personal.Database (Database)
37
+import qualified Web.Hooks.Personal.Database as Database
38
+import qualified Web.Hooks.Personal.Hook as Hook
39
+
40
+--------------------------------------------------------------------------------
41
+data Format = Table | JSON | Plain
42
+
43
+--------------------------------------------------------------------------------
44
+-- | Options needed to list hooks
45
+data Options = Options
46
+  { optionFormat :: Format
47
+  }
48
+
49
+--------------------------------------------------------------------------------
50
+-- | Parse command line options for creating a new hook.
51
+parser :: Parser Options
52
+parser = Options <$> format
53
+  where
54
+    format = table <|> json <|> pure Plain
55
+
56
+    table = flag' Table (mconcat [ long "table"
57
+                                 , short 't'
58
+                                 , help "Format output as a table"
59
+                                 ])
60
+
61
+    json = flag' JSON (mconcat [ long "json"
62
+                               , short 'j'
63
+                               , help "Format output as JSON"
64
+                               ])
65
+
66
+--------------------------------------------------------------------------------
67
+formatted :: [Hook.Hook] -> IO ()
68
+formatted hs =
69
+    putStrLn $ Table.tableString specs Table.asciiS header (map row hs)
70
+
71
+  where
72
+    specs = [Table.numCol, def, def, def]
73
+    header = Table.titlesH ["ID", "Code", "Action", "Expires"]
74
+    row Hook.Hook{..} = Table.rowG [ show hookID
75
+                                   , Text.unpack hookCode
76
+                                   , show hookAction
77
+                                   , maybe "" show hookExpirationTime
78
+                                   ]
79
+
80
+--------------------------------------------------------------------------------
81
+-- | Run the @create@ command to create a new web hook.
82
+run :: Options -> Database -> IO ()
83
+run Options{..} db = do
84
+  hooks <- Database.runQuery db Hook.all :: IO [Hook.Hook]
85
+
86
+  case optionFormat of
87
+    Table -> formatted hooks
88
+    JSON  -> LBS.putStrLn (Aeson.encode hooks)
89
+    Plain -> forM_ hooks $ \Hook.Hook{..} ->
90
+               print (hookID, hookCode, hookAction, hookExpirationTime)

Loading…
Cancel
Save