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 @@
/dist

+ 5
- 0
CHANGES.md View File

@@ -0,0 +1,5 @@
# Revision history for personal-webhooks

## 0.1.0.0 -- YYYY-mm-dd

* First version. Released on an unsuspecting world.

+ 26
- 0
LICENSE View File

@@ -0,0 +1,26 @@
Copyright (c) 2017, Peter Jones <pjones@devalot.com>
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.

2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the
distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
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 @@
import Distribution.Simple
main = defaultMain

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

@@ -0,0 +1,11 @@
create sequence hooks_id_seq;

create table hooks (
id bigint primary key default nextval('hooks_id_seq'),
code text not null,
expires_at timestamp with time zone,
action json not null,

constraint hooks_unique_code unique(code),
constraint hooks_nonblank_code check(code <> '')
);

+ 17
- 0
default.nix View File

@@ -0,0 +1,17 @@
# These arguments are so you can override settings from the command
# line using the `nix-hs' tool.
{ nixpkgs ? import <nixpkgs> { }
, compiler ? "default"
, profiling ? false
}:

let
pkgs = nixpkgs;

buildInputs = with pkgs; [
# List extra dependencies here.
];

in
pkgs.nix-hs.interactive ./personal-webhooks.nix
{ inherit compiler profiling buildInputs; }

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

@@ -0,0 +1,29 @@
{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
-- | Actions for responding to HTTP requests.
module Web.Hooks.Personal.Action
( Action.Action(..)
, Action.Status(..)
, Action.Config(..)
, Action.statusToHTTP
, Action.run
, Action.optionParser
) where

--------------------------------------------------------------------------------
import qualified Web.Hooks.Personal.Action.Config as Action
import qualified Web.Hooks.Personal.Action.Internal as Action
import qualified Web.Hooks.Personal.Action.Options as Action

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

@@ -0,0 +1,41 @@
{-# LANGUAGE OverloadedStrings #-}

{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Web.Hooks.Personal.Action.Config
( Config(..)
) where

--------------------------------------------------------------------------------
import Data.Aeson (FromJSON(parseJSON), withObject, (.:?), (.!=))
import Data.Default (Default(def))

--------------------------------------------------------------------------------
data Config = Config
{ configMaxFileSize :: Integer
-- ^ Maximum number of bytes to all a file to grow before aborting.
}

--------------------------------------------------------------------------------
instance Default Config where
def = Config
{ configMaxFileSize = 1048576 -- 1MB
}

--------------------------------------------------------------------------------
instance FromJSON Config where
parseJSON = withObject "action config" $ \v ->
Config <$> v .:? "maxFileSize" .!= configMaxFileSize def

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

@@ -0,0 +1,128 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
-- | Actions that can be performed in response to an HTTP request.
module Web.Hooks.Personal.Action.Internal
( Action(..)
, Status(..)
, statusToHTTP
, run
) where

--------------------------------------------------------------------------------
-- Library Imports.
import Control.Exception (SomeException, catch)
import Control.Monad (guard)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Maybe (MaybeT(runMaybeT))
import Data.Aeson (ToJSON, FromJSON, encode)
import qualified Data.ByteString.Lazy as LBS
import GHC.Generics (Generic)
import System.Directory (doesFileExist, getFileSize)
import System.IO (IOMode(AppendMode), withFile)

--------------------------------------------------------------------------------
-- Local Imports.
import Web.Hooks.Personal.Action.Config (Config)
import qualified Web.Hooks.Personal.Action.Config as Config
import Web.Hooks.Personal.Database.Generic (liftJSON)
import Web.Hooks.Personal.Request.Internal

--------------------------------------------------------------------------------
-- | The different kinds of actions.
data Action = AppendFileAction FilePath
-- ^ Append incoming data to an existing file.

| NoAction
-- ^ Dummy action.

deriving (Show, Generic)

--------------------------------------------------------------------------------
instance ToJSON Action
instance FromJSON Action
liftJSON ''Action

--------------------------------------------------------------------------------
-- | Possible responses from running an action.
data Status = Okay -- ^ Action ran successfully
| Invalid -- ^ Action can't run due to missing file/info.
| Fail -- ^ Action failed.

--------------------------------------------------------------------------------
-- | Translate a 'Status' into an HTTP status code.
statusToHTTP :: Status -> Int
statusToHTTP Okay = 204
statusToHTTP Invalid = 501
statusToHTTP Fail = 500

--------------------------------------------------------------------------------
-- | Run an action.
run :: (MonadIO m)
=> Config
-- ^ Action configuration.

-> Request
-- ^ Incoming data.

-> Action
-- ^ The action to run.

-> m Status
-- ^ Result status.

run Config.Config{..} (Request v) a = do
result <- liftIO $ catch (runMaybeT action)
(\(_ :: SomeException) -> return $ Just Fail)

case result of
Nothing -> return Invalid
Just r -> return r

where
action :: MaybeT IO Status
action =
case a of
AppendFileAction f -> append f
NoAction -> return Okay
-- Room to grow...

append :: FilePath -> MaybeT IO Status
append file = do
-- Verify the file exists.
exists <- liftIO (doesFileExist file)
guard exists

-- Ensure it won't grow bigger than allowed.
let bs = encode v
bsize = toInteger (LBS.length bs)

size <- liftIO (getFileSize file)
guard (size + bsize <= configMaxFileSize)

-- Safe to append now.
remaining <- liftIO $ withFile file AppendMode (`LBS.hPutNonBlocking` bs)

-- Test to see if all data was written.
if LBS.null remaining
then return Okay
else return Fail

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

@@ -0,0 +1,42 @@
{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
-- | Command line option parser for 'Action'.
module Web.Hooks.Personal.Action.Options
( optionParser
) where

--------------------------------------------------------------------------------
-- Library Imports:
import Options.Applicative

--------------------------------------------------------------------------------
-- Local Imports:
import Web.Hooks.Personal.Action.Internal (Action(..))

--------------------------------------------------------------------------------
-- | Parse an 'Action' from the command line.
optionParser :: Parser Action
optionParser = appendFileAction

--------------------------------------------------------------------------------
-- | Parse an 'AppendFileAction' from the command line.
appendFileAction :: Parser Action
appendFileAction =
AppendFileAction
<$> option str (mconcat [ long "append"
, metavar "FILE"
, help "Append the HTTP request to FILE"
])

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

@@ -0,0 +1,27 @@
{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Web.Hooks.Personal.Database
( Database.Database
, Database.Config(..)
, Database.database
, Database.runQuery
, Database.runInsert
, Database.migrate
) where

--------------------------------------------------------------------------------
import qualified Web.Hooks.Personal.Database.Config as Database
import qualified Web.Hooks.Personal.Database.Internal as Database

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

@@ -0,0 +1,47 @@
{-# LANGUAGE OverloadedStrings #-}

{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Web.Hooks.Personal.Database.Config
( Config(..)
) where

--------------------------------------------------------------------------------
import Data.Aeson (FromJSON(parseJSON), withObject, (.:?), (.!=))
import Data.Default (Default(def))
import Data.Text (Text)

--------------------------------------------------------------------------------
data Config = Config
{ configConnectionString :: Text
-- ^ libpq connection string.

, configPoolSize :: Int
-- ^ Size of the database connection pool.
}

--------------------------------------------------------------------------------
instance Default Config where
def = Config
{ configConnectionString = "user=webhooks dbname=webhooks password=webhooks"
, configPoolSize = 5
}

--------------------------------------------------------------------------------
instance FromJSON Config where
parseJSON = withObject "database config" $ \v ->
Config <$> v .:? "connection" .!= configConnectionString def
<*> v .:? "poolSize" .!= configPoolSize def

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

@@ -0,0 +1,29 @@
{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
-- | Access to PostgreSQL functions.
module Web.Hooks.Personal.Database.Functions
( now
) where

--------------------------------------------------------------------------------
import Opaleye.Internal.Column (Column(..))
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import Opaleye.PGTypes

--------------------------------------------------------------------------------
-- | Current transaction time.
now :: Column PGTimestamptz
now = Column (HPQ.FunExpr "now" [])

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

@@ -0,0 +1,70 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}

{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
-- | Use generic PostgreSQL columns to hold Haskell types.
module Web.Hooks.Personal.Database.Generic
( LiftJSON(..)
, liftJSON
) where

--------------------------------------------------------------------------------
-- Library Imports:
import Data.Aeson (ToJSON, FromJSON)
import qualified Data.Aeson as Aeson
import Data.Profunctor.Product.Default (Default(def))
import Data.Typeable (Typeable)
import Database.PostgreSQL.Simple.FromField (FromField(..), Conversion, ResultError(..), returnError)
import qualified Language.Haskell.TH as TH
import Opaleye

--------------------------------------------------------------------------------
-- | A type wrapper to lift another type into PostgreSQL via @PGJson@.
newtype LiftJSON a = LiftJSON { unliftJSON :: a }

--------------------------------------------------------------------------------
instance (FromJSON a, Typeable a) => FromField (LiftJSON a) where
fromField f b = go =<< fromField f b
where
go :: (FromJSON a, Typeable a) => Aeson.Value -> Conversion (LiftJSON a)
go v = case Aeson.fromJSON v of
Aeson.Success x -> return (LiftJSON x)
Aeson.Error e -> returnError ConversionFailed f e

--------------------------------------------------------------------------------
instance (FromJSON a, Typeable a) => QueryRunnerColumnDefault PGJson (LiftJSON a) where
queryRunnerColumnDefault = fieldQueryRunnerColumn

--------------------------------------------------------------------------------
instance (ToJSON a) => Default Constant (LiftJSON a) (Column PGJson) where
def = Constant (pgValueJSON . Aeson.toJSON . unliftJSON)

--------------------------------------------------------------------------------
-- | Use Template Haskell to generate database instances for @PGJson@.
liftJSON :: TH.Name -> TH.Q [TH.Dec]
liftJSON name =
[d|
instance FromField $(TH.conT name) where
fromField f b = unliftJSON <$> fromField f b

instance QueryRunnerColumnDefault PGJson $(TH.conT name) where
queryRunnerColumnDefault = unliftJSON <$> queryRunnerColumnDefault

instance Default Constant $(TH.conT name) (Column PGJson) where
def = Constant (pgValueJSON . Aeson.toJSON)
|]

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

@@ -0,0 +1,131 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}

{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Web.Hooks.Personal.Database.Internal
( Database
, database
, runQuery
, runInsert
, migrate
) where

--------------------------------------------------------------------------------
-- Library Imports:
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Int (Int64)
import Data.Pool (Pool)
import qualified Data.Pool as Pool
import Data.Profunctor.Product.Default (Default)
import qualified Data.Text.Encoding as Text
import Database.PostgreSQL.Simple (Connection)
import qualified Database.PostgreSQL.Simple as PostgreSQL
import qualified Opaleye
import System.Exit (die)
import System.FilePath ((</>))

--------------------------------------------------------------------------------
-- For database migrations:
import Database.PostgreSQL.Simple.Util (existsTable)
import Database.PostgreSQL.Simple.Migration ( MigrationCommand(..)
, MigrationResult(..)
, runMigrations
)

--------------------------------------------------------------------------------
-- Local Imports:
import Paths_personal_webhooks (getDataDir)
import Web.Hooks.Personal.Database.Config

--------------------------------------------------------------------------------
-- | A database handle.
data Database = Database
{ dbPool :: Pool Connection
}

--------------------------------------------------------------------------------
-- | Given a configuration object, create a database handle.
database :: (MonadIO m) => Config -> m Database
database Config{..} = do
pool <- liftIO (Pool.createPool connect close 1 timeout configPoolSize)
return (Database pool)
where
constr = Text.encodeUtf8 configConnectionString
connect = PostgreSQL.connectPostgreSQL constr
close = PostgreSQL.close
timeout = 30

--------------------------------------------------------------------------------
-- | Internal function to get a connection out of the pool.
withConnection :: (MonadIO m) => Database -> (Connection -> IO a) -> m a
withConnection Database{..} = liftIO . Pool.withResource dbPool

--------------------------------------------------------------------------------
-- | Run an Opaleye query (SELECT).
runQuery :: (MonadIO m, Default Opaleye.QueryRunner cs h)
=> Database
-- ^ A 'Database' object.

-> Opaleye.Query cs
-- ^ The query you want to execute.

-> m [h]
-- ^ Query results, converted into the correct type.

runQuery d q = withConnection d $ \c -> Opaleye.runQuery c q

--------------------------------------------------------------------------------
-- | Run an Opaleye insert.
runInsert :: (MonadIO m, Default Opaleye.Constant h cs)
=> Database
-- ^ A 'Database' object.

-> Opaleye.Table cs cs'
-- ^ The table to insert into.

-> [h]
-- ^ List of values to insert. These will automatically be
-- converted into the appropriate PostgreSQL columns types.

-> m Int64
-- ^ Number of rows inserted.

runInsert d t hs =
withConnection d $ \c ->
Opaleye.runInsertMany c t (map Opaleye.constant hs)

--------------------------------------------------------------------------------
-- | Run the database migrations. Exits the current process if there
-- is an error running the migrations.
migrate :: (MonadIO m) => Database -> Bool -> m ()
migrate d verbose = withConnection d go
where
go :: Connection -> IO ()
go c = do
inited <- existsTable c "schema_migrations"
datadir <- liftIO getDataDir

let dir = datadir </> "data" </> "migrations"
mi = if inited then [] else [MigrationInitialization]
ms = mi ++ [MigrationDirectory dir]

result <- PostgreSQL.withTransaction c $
runMigrations verbose c ms

case result of
MigrationSuccess -> return ()
MigrationError e -> die e

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

@@ -0,0 +1,29 @@
{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
-- | Hook type and functions.
module Web.Hooks.Personal.Hook
( Hook.Hook
, Hook.HookNotSaved
, Hook.Hook'(..)
, Hook.hook
, Hook.table
, Hook.all
, Hook.find
) where

--------------------------------------------------------------------------------
import qualified Web.Hooks.Personal.Hook.Database as Hook
import qualified Web.Hooks.Personal.Hook.Internal as Hook

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

@@ -0,0 +1,62 @@
{-# LANGUAGE Arrows #-}

{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Web.Hooks.Personal.Hook.Database
( table
, all
, find
) where

--------------------------------------------------------------------------------
-- Library Imports:
import Control.Arrow (returnA)
import Data.Text (Text)
import Opaleye
import Prelude hiding (all)

--------------------------------------------------------------------------------
-- Local Imports:
import Web.Hooks.Personal.Database.Functions (now)
import Web.Hooks.Personal.Hook.Internal

--------------------------------------------------------------------------------
-- | Opaleye defintion for the hooks table.
table :: Table HookW HookR
table = Table "hooks"
(pHook Hook { hookID = optional "id"
, hookCode = required "code"
, hookExpirationTime = required "expires_at"
, hookAction = required "action"
})

--------------------------------------------------------------------------------
-- | Fetch all hooks.
all :: Query HookR
all = queryTable table

--------------------------------------------------------------------------------
-- | Find a hook based on its secret code.
find :: Text -> Query HookR
find code = proc () -> do
row <- queryTable table -< ()
restrict -< hookCode row .== pgStrictText code
restrict -< isNull (hookExpirationTime row) .|| notExpired row
returnA -< row

where
notExpired :: HookR -> Column PGBool
notExpired row = fromNullable now (hookExpirationTime row) .< now

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

@@ -0,0 +1,114 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
-- | Information about how to handle an HTTP request.
module Web.Hooks.Personal.Hook.Internal
( Hook
, HookNotSaved
, Hook'(..)
, HookR
, HookW
, pHook
, hook
) where

--------------------------------------------------------------------------------
-- Library Imports.
import qualified Codec.Binary.Base64Url as Base64
import Control.Monad.IO.Class (MonadIO, liftIO)
import Crypto.Random (randomBytesGenerate, drgNewSeed, seedNew)
import Data.Aeson (ToJSON, FromJSON)
import Data.Int (Int64)
import Data.Profunctor.Product.Default (Default(def))
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import Data.Time (UTCTime)
import GHC.Generics (Generic)
import Opaleye (Column, Nullable, Constant(..), constant)
import Opaleye.PGTypes

--------------------------------------------------------------------------------
-- Local Imports.
import Web.Hooks.Personal.Action.Internal (Action)

--------------------------------------------------------------------------------
-- | Type alias to make the @Hook'@ type concrete.
type HookNotSaved = Hook' (Maybe Int64) Text (Maybe UTCTime) Action
type Hook = Hook' Int64 Text (Maybe UTCTime) Action

--------------------------------------------------------------------------------
-- | Polymorphic hook suitable for storing in a database.
data Hook' key text time action = Hook
{ hookID :: key
-- ^ Database ID.

, hookCode :: text
-- ^ Secret code.

, hookExpirationTime :: time
-- ^ Optional expiration time for the hook.

, hookAction :: action
-- ^ The action to run for this hook.
} deriving (Generic, Show)

--------------------------------------------------------------------------------
instance ToJSON Hook
instance FromJSON Hook

--------------------------------------------------------------------------------
-- | Create profunctor-product instances for Opaleye.
$(makeAdaptorAndInstance "pHook" ''Hook')

--------------------------------------------------------------------------------
-- | Concrete hook type for reading columns from the database.
type HookR = Hook' (Column PGInt8) -- ID
(Column PGText) -- Code
(Column (Nullable PGTimestamptz)) -- Expiration date.
(Column PGJson) -- Action (encoded as JSON)

--------------------------------------------------------------------------------
-- | Concrete hook type for writing columns to the database.
type HookW = Hook' (Maybe (Column PGInt8)) -- Auto increment ID.
(Column PGText) -- Code
(Column (Nullable PGTimestamptz)) -- Expiration date.
(Column PGJson) -- Action (encoded as JSON)

--------------------------------------------------------------------------------
instance Default Constant Hook ( Maybe (Column PGInt8)
, Column PGText
, Column (Nullable PGTimestamptz)
, Column PGJson
) where
def = Constant $ \Hook{..} -> ( Nothing
, constant hookCode
, constant hookExpirationTime
, constant hookAction
)

--------------------------------------------------------------------------------
-- | Helper function to construct a hook with a unique @hookCode@.
hook :: (MonadIO m) => Maybe UTCTime -> Action -> m HookNotSaved
hook time action = do
bytes <- liftIO (fst . randomBytesGenerate 48 . drgNewSeed <$> seedNew)
let code = Text.decodeUtf8 (Base64.encode bytes)
return (Hook Nothing code time action)

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

@@ -0,0 +1,25 @@
{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}
--------------------------------------------------------------------------------
-- | Request data to pass along to a hook action.
module Web.Hooks.Personal.Request
( Request.Request
, Request.fromJSON
, Request.fromParams
, Request.Config(..)
) where

--------------------------------------------------------------------------------
import qualified Web.Hooks.Personal.Request.Config as Request
import qualified Web.Hooks.Personal.Request.Internal as Request

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

@@ -0,0 +1,41 @@
{-# LANGUAGE OverloadedStrings #-}

{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Web.Hooks.Personal.Request.Config
( Config(..)
) where

--------------------------------------------------------------------------------
import Data.Aeson (FromJSON(parseJSON), withObject, (.:?), (.!=))
import Data.Default (Default(def))

--------------------------------------------------------------------------------
data Config = Config
{ configMaxBodySize :: Int
-- ^ Maximum number of bytes to read from an HTTP body.
}

--------------------------------------------------------------------------------
instance Default Config where
def = Config
{ configMaxBodySize = 2048 -- 2k
}

--------------------------------------------------------------------------------
instance FromJSON Config where
parseJSON = withObject "request config" $ \v ->
Config <$> v .:? "maxBodySize" .!= configMaxBodySize def

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

@@ -0,0 +1,49 @@
{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
-- | Internal implementation of the 'Request' type and functions.
module Web.Hooks.Personal.Request.Internal
( Request(..)
, fromJSON
, fromParams
) where

--------------------------------------------------------------------------------
-- Library Imports:
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as Map
import Data.Text (Text)
import qualified Data.Text.Encoding as Text

--------------------------------------------------------------------------------
-- | A type to represent an HTTP request.
newtype Request = Request Aeson.Value

--------------------------------------------------------------------------------
-- | Create a 'Request' from a string containing JSON data.
fromJSON :: L.ByteString -> Maybe Request
fromJSON = fmap Request . Aeson.decode

--------------------------------------------------------------------------------
-- | Create a 'Request' from decoded query parameters.
fromParams :: Map B.ByteString [B.ByteString] -> Maybe Request
fromParams =
Just . Request . Aeson.toJSON . Map.fromList . map convert . Map.toList
where
convert :: (B.ByteString, [B.ByteString]) -> (Text, [Text])
convert (k, vs) = (Text.decodeUtf8 k, map Text.decodeUtf8 vs)

+ 105
- 0
personal-webhooks.cabal View File

@@ -0,0 +1,105 @@
name: personal-webhooks
version: 0.1.0.0
synopsis: Trigger personal scripts from incoming HTTP requests
license: BSD2
license-file: LICENSE
author: Peter Jones <pjones@devalot.com>
maintainer: Peter Jones <pjones@devalot.com>
copyright: Copyright (c) 2017 Peter J. Jones
category: Web
build-type: Simple
cabal-version: >=1.10
-- description:

--------------------------------------------------------------------------------
extra-source-files:
README.md
CHANGES.md

--------------------------------------------------------------------------------
-- Files needed at run time.
data-files:
data/migrations/*.sql

--------------------------------------------------------------------------------
source-repository head
type: git
location: git://github.com/pjones/personal-webhooks.git

--------------------------------------------------------------------------------
flag maintainer
description: Enable settings for the package maintainer.
manual: True
default: False

--------------------------------------------------------------------------------
library
exposed-modules:
Web.Hooks.Personal.Action
Web.Hooks.Personal.Action.Config
Web.Hooks.Personal.Action.Internal
Web.Hooks.Personal.Action.Options
Web.Hooks.Personal.Database
Web.Hooks.Personal.Database.Config
Web.Hooks.Personal.Database.Functions
Web.Hooks.Personal.Database.Generic
Web.Hooks.Personal.Database.Internal
Web.Hooks.Personal.Hook
Web.Hooks.Personal.Hook.Database
Web.Hooks.Personal.Hook.Internal
Web.Hooks.Personal.Request
Web.Hooks.Personal.Request.Config
Web.Hooks.Personal.Request.Internal
other-modules:
Paths_personal_webhooks

hs-source-dirs: lib
default-language: Haskell2010
ghc-options: -Wall -fwarn-incomplete-uni-patterns -Wincomplete-record-updates

if flag(maintainer)
ghc-options: -Werror

build-depends: base >= 4.9 && < 5
, aeson >= 1.1 && < 1.3
, bytestring >= 0.10 && < 0.11
, containers >= 0.5 && < 0.6
, cryptonite >= 0.23 && < 0.24
, data-default >= 0.7 && < 1.0
, directory >= 1.3 && < 1.4
, filepath >= 1.4 && < 1.5
, opaleye >= 0.5 && < 0.7
, optparse-applicative >= 0.13 && < 0.15
, postgresql-simple >= 0.5 && < 0.6
, postgresql-simple-migration >= 0.1 && < 0.2
, product-profunctors >= 0.8 && < 0.9
, profunctors >= 5.2 && < 5.3
, resource-pool >= 0.2 && < 0.3
, sandi >= 0.4 && < 0.5
, template-haskell >= 2.11 && < 2.12
, text >= 1.2 && < 1.3
, time >= 1.6 && < 1.9
, transformers >= 0.5 && < 1.0

--------------------------------------------------------------------------------
executable webhooks
other-modules:
UI.Create
UI.List
hs-source-dirs: src
main-is: Main.hs
default-language: Haskell2010

build-depends: base
, aeson
, bytestring
, data-default
, optparse-applicative
, personal-webhooks
, table-layout >= 0.8 && < 0.9
, text

if flag(maintainer)
ghc-options: -Werror

+ 26
- 0
personal-webhooks.nix View File

@@ -0,0 +1,26 @@
{ mkDerivation, aeson, base, bytestring, containers, cryptonite
, data-default, directory, filepath, opaleye, optparse-applicative
, postgresql-simple, postgresql-simple-migration
, product-profunctors, profunctors, resource-pool, sandi, stdenv
, table-layout, template-haskell, text, time, transformers
}:
mkDerivation {
pname = "personal-webhooks";
version = "0.1.0.0";
src = ./.;
isLibrary = true;
isExecutable = true;
enableSeparateDataOutput = true;
libraryHaskellDepends = [
aeson base bytestring containers cryptonite data-default directory
filepath opaleye optparse-applicative postgresql-simple
postgresql-simple-migration product-profunctors profunctors
resource-pool sandi template-haskell text time transformers
];
executableHaskellDepends = [
aeson base bytestring data-default optparse-applicative
table-layout text
];
description = "Trigger personal scripts from incoming HTTP requests";
license = stdenv.lib.licenses.bsd2;
}

+ 10
- 0
scripts/devrun.sh View File

@@ -0,0 +1,10 @@
#!/bin/sh

################################################################################
# Wrapper around the webhooks executable that points it at the correct
# data-dir so it can find its migrations and other necessary files.
set -e

################################################################################
export personal_webhooks_datadir=$(pwd)
dist/build/webhooks/webhooks "$@"

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

@@ -0,0 +1,9 @@
#!/bin/sh

################################################################################
set -e

################################################################################
name=$(date +%Y%m%dT%M%H%S)-"$1".sql
touch data/migrations/"$name"
echo "$name"

+ 74
- 0
src/Main.hs View File

@@ -0,0 +1,74 @@
{-# LANGUAGE OverloadedStrings #-}

{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Main (main) where

--------------------------------------------------------------------------------
-- Library Imports:
import Data.Default (def)
import Options.Applicative

--------------------------------------------------------------------------------
-- Local Imports:
import qualified UI.Create as Create
import qualified UI.List as List
import qualified Web.Hooks.Personal.Database as Database

--------------------------------------------------------------------------------
-- | Subcommand.
data Command = Create Create.Options -- ^ Create a new hook.
| List List.Options -- ^ List hooks.

--------------------------------------------------------------------------------
-- | Command line options
data Options = Options
{ optionCommand :: Command
-- ^ Which subcommand to run.
}

--------------------------------------------------------------------------------
-- | Command line option parser.
parser :: Parser Options
parser =
Options
<$> subparser (mconcat [ createCommand
, listCommand
])

where
mkCmd :: String -> String -> Parser a -> Mod CommandFields a
mkCmd name desc p =
command name (info (p <**> helper) (progDesc desc))

createCommand =
mkCmd "create" "Create a new webhook" (Create <$> Create.parser)

listCommand =
mkCmd "list" "List hooks" (List <$> List.parser)

--------------------------------------------------------------------------------
-- | Main entry point.
main :: IO ()
main = do
options <- execParser $ info (parser <**> helper) idm

database <- Database.database def
Database.migrate database False

case optionCommand options of
Create o -> Create.run o database
List o -> List.run o database

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

@@ -0,0 +1,53 @@
{-# LANGUAGE RecordWildCards #-}

{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module UI.Create
( Options
, parser
, run
) where

--------------------------------------------------------------------------------
-- Library Imports:
import qualified Data.Text as Text
import Options.Applicative

--------------------------------------------------------------------------------
-- Local Imports:
import qualified Web.Hooks.Personal.Action as Action
import Web.Hooks.Personal.Database (Database)
import qualified Web.Hooks.Personal.Database as Database
import qualified Web.Hooks.Personal.Hook as Hook

--------------------------------------------------------------------------------
-- | Options needed to create a new hook.
data Options = Options
{ optionAction :: Action.Action
}

--------------------------------------------------------------------------------
-- | Parse command line options for creating a new hook.
parser :: Parser Options
parser = Options <$> Action.optionParser

--------------------------------------------------------------------------------
-- | Run the @create@ command to create a new webhook.
run :: Options -> Database -> IO ()
run Options{..} db = do
h <- Hook.hook Nothing optionAction
_ <- Database.runInsert db Hook.table [h]
putStrLn ("New hook code: " ++ Text.unpack (Hook.hookCode h))

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

@@ -0,0 +1,90 @@
{-# LANGUAGE RecordWildCards #-}

{-

This file is part of the package personal-webhooks. It is subject to
the license terms in the LICENSE file found in the top-level directory
of this distribution and at:

git://git.devalot.com/personal-webhooks.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module UI.List
( Options
, parser
, run
) where

--------------------------------------------------------------------------------
-- Library Imports:
import Control.Monad (forM_)
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Default (def)
import qualified Data.Text as Text
import Options.Applicative
import qualified Text.Layout.Table as Table

--------------------------------------------------------------------------------
-- Local Imports:
import Web.Hooks.Personal.Database (Database)
import qualified Web.Hooks.Personal.Database as Database
import qualified Web.Hooks.Personal.Hook as Hook

--------------------------------------------------------------------------------
data Format = Table | JSON | Plain

--------------------------------------------------------------------------------
-- | Options needed to list hooks
data Options = Options
{ optionFormat :: Format
}

--------------------------------------------------------------------------------
-- | Parse command line options for creating a new hook.
parser :: Parser Options
parser = Options <$> format
where
format = table <|> json <|> pure Plain

table = flag' Table (mconcat [ long "table"
, short 't'
, help "Format output as a table"
])

json = flag' JSON (mconcat [ long "json"
, short 'j'
, help "Format output as JSON"
])

--------------------------------------------------------------------------------
formatted :: [Hook.Hook] -> IO ()
formatted hs =
putStrLn $ Table.tableString specs Table.asciiS header (map row hs)

where
specs = [Table.numCol, def, def, def]
header = Table.titlesH ["ID", "Code", "Action", "Expires"]
row Hook.Hook{..} = Table.rowG [ show hookID
, Text.unpack hookCode
, show hookAction
, maybe "" show hookExpirationTime
]

--------------------------------------------------------------------------------
-- | Run the @create@ command to create a new web hook.
run :: Options -> Database -> IO ()
run Options{..} db = do
hooks <- Database.runQuery db Hook.all :: IO [Hook.Hook]

case optionFormat of
Table -> formatted hooks
JSON -> LBS.putStrLn (Aeson.encode hooks)
Plain -> forM_ hooks $ \Hook.Hook{..} ->
print (hookID, hookCode, hookAction, hookExpirationTime)

Loading…
Cancel
Save