Browse Source

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

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

+ 1
- 1
LICENSE View File

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

Redistribution and use in source and binary forms, with or without

+ 76
- 0
README.md View File

@@ -0,0 +1,76 @@
# Trigger personal scripts from incoming HTTP requests

Ever wish you could do something custom with all those web hooks
offered by various web service providers? This package provides an
easy and safe way to do just that.

## Example: Tagging a video will download and sync it to your phone

In the `examples` directory there is a script named
`download-video.sh`. Here is how I use it:

* When I want to watch a video later, probably on an airplane, I tag
the video in my RSS feed reader (<https://feedly.com/>).

* That triggers an [IFTTT](https://ifttt.com/) applet which uses the
IFTTT support for calling a web hook and calls into this package.

* This package runs the `download-video.sh` script which downloads
the video to a directory that is automatically synced with my
phone.

## How this package works

This package includes an executable called `webhooks`. This
executable can be used to create new hooks from the command line or
run a web server to respond to incoming requests. A hook is just an
indirect way to run a script if you know the hook's secret code.

For security reasons, the web server does *not* run scripts directly.
Instead, if the incoming request correctly maps to an existing hook,
the request data will be appended to an existing file as JSON.

"Okay, but how does appending JSON to a file help me?" you ask. Good
question. Thanks to the magic of POSIX named pipes (FIFOs), you can
feed that JSON data into a waiting script.

## Setting up the example web hook

1. Run the HTTP server provided by this package:

$ webhooks server --port 3000

2. Create a new web hook that appends to a file. In this example
we'll configure a hook to append to the file `/tmp/foo.pipe`:

$ webhooks create --append /tmp/foo.pipe

This command will print a secret code for the newly created hook.
(If you forget the hook's secret code you can use the `webhooks
list` command to look it up again.)

3. Run a script that creates the named pipe and then reads lines
from it. In the `examples` directory there is a script that will
do this for you and then execute other commands as requests come
in. (The commands receive JSONs request on their stdin.)

$ examples/watchfifo.sh -f /tmp/foo.pipe -- examples/download-video.sh

4. Use the hook's secret code to trigger your script. In this
example we'll pretend that the secret code is `XXX`.

$ curl --data url=https://player.vimeo.com/video/148946917 \
http://localhost:3000/hooks/XXX

This leads to the `download-video.sh` script running and being
fed the following JSON:

{"url": "https://player.vimeo.com/video/148946917"}

Ideally, you should run the `webhooks` server behind a reverse proxy
that is properly configured for TLS. This will prevent hook codes
from being exposed to the network unencrypted. To encourage this, the
server only binds to the loopback device.

More details about installing and running this package can be found in
the installation guide.

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

@@ -1,7 +1,6 @@
create sequence hooks_id_seq;

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

create index on hooks (code, expires_at);

+ 15
- 0
docs/TODO.org View File

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

+ 20
- 7
examples/watchfifo.sh View File

@@ -14,35 +14,40 @@
#
################################################################################
#
# Execute a command for each line read from a fifo.
# Execute a command for each line read from a FIFO.
#
# For example, to use in conjunction with the download-video.sh script:
#
# watchfifo.sh -f /tmp/download.fifo -- download-video.sh -d ~/Downloads
#
# Lines read from the fifo are piped into the given command's stdin.
# Lines read from the FIFO are piped into the given command's stdin.
#
################################################################################
set -e
option_fifo_file=""
option_group=""

################################################################################
usage () {
cat <<EOF
Usage: watchfifo.sh [options] -- command [arg, arg, ...]
Usage: watchfifo.sh [options] -- command [arg1, arg2, ...]

-f FILE The fifo file to create and manage
-f FILE The FIFO file to create and manage
-g GRP Set the FIFO file's group to GRP
-h This message

EOF
}

################################################################################
while getopts "f:h" o; do
while getopts "f:g:h" o; do
case "${o}" in
f) option_fifo_file=$OPTARG
;;

g) option_group=$OPTARG
;;

h) usage
exit
;;
@@ -67,10 +72,14 @@ prepare() {
fi

if [ -r "$option_fifo_file" ]; then
die "fifo file exists, remove it first: $option_fifo_file"
die "FIFO file exists, remove it first: $option_fifo_file"
fi

mkfifo -m 0622 "$option_fifo_file"
mkfifo -m 0620 "$option_fifo_file"

if [ -n "$option_group" ]; then
chgrp "$option_group" "$option_fifo_file"
fi
}

################################################################################
@@ -79,6 +88,10 @@ cleanup() {
}

################################################################################
if [ $# -le 0 ]; then
die "please provide a command to run after -- "
fi

export IFS=$'\n'
trap cleanup EXIT
prepare

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

@@ -31,6 +31,7 @@ import Data.Bifunctor (bimap)
import Data.Default (Default(def))
import qualified Data.Yaml as YAML
import System.Directory (XdgDirectory(..), getXdgDirectory, doesFileExist)
import System.FilePath ((</>))

--------------------------------------------------------------------------------
-- Local imports:
@@ -64,7 +65,9 @@ instance FromJSON Config where
--------------------------------------------------------------------------------
-- | The path to the default configuration file.
defaultPath :: (MonadIO m) => m FilePath
defaultPath = liftIO (getXdgDirectory XdgConfig "webhooks")
defaultPath = do
dir <- liftIO (getXdgDirectory XdgConfig "webhooks")
return (dir </> "config.yml")

--------------------------------------------------------------------------------
-- | Parse the given configuration file.

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

@@ -33,7 +33,7 @@ module Web.Hooks.Personal.Internal.Action.Prim
import Control.Exception (SomeException, catch)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import Data.Aeson (ToJSON, FromJSON, encode)
import Data.Aeson (ToJSON, FromJSON, encode, toJSON)
import qualified Data.ByteString.Lazy as LBS
import Data.Maybe (isJust)
import Data.Monoid ((<>))
@@ -89,7 +89,7 @@ run :: (MonadIO m)
-> m Status
-- ^ Result status.

run Config.Config{..} (Request v) a =
run Config.Config{..} r a =
statusFromEither <$> liftIO (catch (runExceptT action) handleE)

where
@@ -110,7 +110,7 @@ run Config.Config{..} (Request v) a =
assert exists (Invalid $ "file doesn't exist: " ++ file)

-- Ensure it won't grow bigger than allowed.
let bs = encode v <> "\n"
let bs = encode (toJSON r) <> "\n"
bsize = toInteger (LBS.length bs)

size <- liftIO (getFileSize file)

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

@@ -22,10 +22,11 @@ module Web.Hooks.Personal.Internal.Request.Config
--------------------------------------------------------------------------------
import Data.Aeson (FromJSON(parseJSON), withObject, (.:?), (.!=))
import Data.Default (Default(def))
import Data.Word (Word64)

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


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

@@ -31,19 +31,39 @@ import Data.Text (Text)
import qualified Data.Text.Encoding as Text

--------------------------------------------------------------------------------
newtype Request = Request Aeson.Value
-- | A type to represent the data sent with an HTTP request.
data Request = RequestParams (Map Text Value)
| RequestJSON Aeson.Value

--------------------------------------------------------------------------------
-- | Helper type to collapse query parameters that only have one value.
data Value = Single Text | Multiple [Text]

--------------------------------------------------------------------------------
instance Aeson.ToJSON Request where
toJSON (RequestParams p) = Aeson.toJSON p
toJSON (RequestJSON v) = v

--------------------------------------------------------------------------------
instance Aeson.ToJSON Value where
toJSON (Single t) = Aeson.String t
toJSON (Multiple ts) = Aeson.toJSON ts

--------------------------------------------------------------------------------
-- | Create a 'Request' from a string containing JSON data.
fromJSON :: L.ByteString -> Maybe Request
fromJSON = fmap Request . Aeson.decode
fromJSON = fmap RequestJSON . 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
fromParams = Just . RequestParams . Map.fromList . map convert . Map.toList
where
convert :: (B.ByteString, [B.ByteString]) -> (Text, [Text])
convert (k, vs) = (Text.decodeUtf8 k, map Text.decodeUtf8 vs)
convert :: (B.ByteString, [B.ByteString]) -> (Text, Value)
convert (k, vs) = ( Text.decodeUtf8 k
, mkValue (map Text.decodeUtf8 vs)
)

mkValue :: [Text] -> Value
mkValue [x] = Single x
mkValue xs = Multiple xs

+ 5
- 5
personal-webhooks.cabal View File

@@ -5,7 +5,7 @@ license: BSD2
license-file: LICENSE
author: Peter Jones <pjones@devalot.com>
maintainer: Peter Jones <pjones@devalot.com>
copyright: Copyright (c) 2017 Peter J. Jones
copyright: Copyright (c) 2017,2018 Peter J. Jones
category: Web
build-type: Simple
cabal-version: >=1.10
@@ -41,6 +41,7 @@ library
Web.Hooks.Personal.Env
Web.Hooks.Personal.Hook
Web.Hooks.Personal.Request
-- Web.Hooks.Personal.Internal
-- Web.Hooks.Personal.Internal.Action
Web.Hooks.Personal.Internal.Action.Config
Web.Hooks.Personal.Internal.Action.Options
@@ -82,12 +83,8 @@ library
, 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
, snap >= 1.0 && < 1.1
, snap-core >= 1.0 && < 1.1
, snap-server >= 1.0 && < 1.1
, template-haskell >= 2.11 && < 2.12
, text >= 1.2 && < 1.3
, time >= 1.6 && < 1.9
@@ -100,6 +97,7 @@ executable webhooks
UI.Create
UI.List
UI.Run
UI.Server

hs-source-dirs: src
main-is: Main.hs
@@ -113,6 +111,8 @@ executable webhooks
, opaleye
, optparse-applicative
, personal-webhooks
, snap-core >= 1.0 && < 1.1
, snap-server >= 1.0 && < 1.1
, table-layout >= 0.8 && < 0.9
, text
, transformers

+ 6
- 7
personal-webhooks.nix View File

@@ -1,9 +1,9 @@
{ mkDerivation, aeson, base, bytestring, containers, cryptonite
, data-default, directory, filepath, opaleye, optparse-applicative
, postgresql-simple, postgresql-simple-migration
, product-profunctors, profunctors, resource-pool, sandi, snap
, snap-core, snap-server, stdenv, table-layout, template-haskell
, text, time, transformers, yaml
, product-profunctors, resource-pool, sandi, snap-core, snap-server
, stdenv, table-layout, template-haskell, text, time, transformers
, yaml
}:
mkDerivation {
pname = "personal-webhooks";
@@ -15,13 +15,12 @@ mkDerivation {
libraryHaskellDepends = [
aeson base bytestring containers cryptonite data-default directory
filepath opaleye optparse-applicative postgresql-simple
postgresql-simple-migration product-profunctors profunctors
resource-pool sandi snap snap-core snap-server template-haskell
text time transformers yaml
postgresql-simple-migration product-profunctors resource-pool sandi
template-haskell text time transformers yaml
];
executableHaskellDepends = [
aeson base bytestring data-default opaleye optparse-applicative
table-layout text transformers
snap-core snap-server table-layout text transformers
];
description = "Trigger personal scripts from incoming HTTP requests";
license = stdenv.lib.licenses.bsd2;

+ 7
- 0
src/Main.hs View File

@@ -27,6 +27,7 @@ import Options.Applicative
import qualified UI.Create as Create
import qualified UI.List as List
import qualified UI.Run as Run
import qualified UI.Server as Server
import qualified Web.Hooks.Personal.Env as Env

--------------------------------------------------------------------------------
@@ -34,6 +35,7 @@ import qualified Web.Hooks.Personal.Env as Env
data Command = Create Create.Options -- ^ Create a new hook.
| List List.Options -- ^ List hooks.
| Run Run.Options -- ^ Run hooks.
| Server Server.Options -- ^ Web server.

--------------------------------------------------------------------------------
-- | Command line options
@@ -61,6 +63,7 @@ parser =
<*> subparser (mconcat [ createCommand
, listCommand
, runCommand
, serverCommand
])

where
@@ -77,6 +80,9 @@ parser =
runCommand =
mkCmd "run" "Run hooks" (Run <$> Run.parser)

serverCommand =
mkCmd "server" "Run the web server" (Server <$> Server.parser)

--------------------------------------------------------------------------------
-- | Main entry point.
main :: IO ()
@@ -89,3 +95,4 @@ main = do
Create o -> Create.run o
List o -> List.run o
Run o -> Run.run o
Server o -> Server.run o

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

@@ -0,0 +1,151 @@
{-# LANGUAGE OverloadedStrings #-}
{-# 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.Server
( Options
, parser
, run
) where

--------------------------------------------------------------------------------
-- Library Imports:
import Control.Monad (mzero)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.Reader
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import Data.Word (Word64)
import Options.Applicative
import Snap.Core
import qualified Snap.Http.Server as HTTP

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

--------------------------------------------------------------------------------
-- | Command line options.
data Options = Options
{ optionPort :: Int
}

--------------------------------------------------------------------------------
-- | Command line parser.
parser :: Parser Options
parser =
Options <$> option auto (mconcat [ long "port"
, short 'p'
, metavar "NUM"
, help "The port number to bind to"
])

--------------------------------------------------------------------------------
-- | Fetch a hook from the database and run its action.
findAndRunHook :: (MonadIO m)
=> Env
-> Text
-> Request.Request
-> MaybeT m Action.Status

findAndRunHook env code request = do
a <- Hook.hookAction <$> findByCode
Action.run actionConfig request a

where
findByCode :: (MonadIO m) => MaybeT m Hook
findByCode = listToMaybeT =<<
Database.runQuery (Env.database env)
(Hook.findBy $ Hook.HookCode code)

actionConfig :: Action.Config
actionConfig = Config.configAction (Env.config env)

listToMaybeT :: (Monad m) => [a] -> MaybeT m a
listToMaybeT [] = mzero
listToMaybeT (x:_) = return x

--------------------------------------------------------------------------------
-- | Routes.
site :: Env -> Snap ()
site env = route [ ("hooks/:hookcode", handler env) ]

--------------------------------------------------------------------------------
-- | Request handler.
handler :: Env -> Snap ()
handler env = do
-- Review the request and try to run a hook.
status <- runMaybeT $ do
rq <- lift getRequest

rdata <- -- Where the data comes from varies based on the request.
case (rqMethod rq, getHeader "Content-Type" rq) of
(GET, _) -> fromParams rq
(POST, Just "application/x-www-form-urlencoded") -> fromParams rq
(POST, Just "application/json") -> fromJSON
(_, _) {- Anything else is a failure -} -> mzero

code <- MaybeT (getParam "hookcode")
findAndRunHook env (Text.decodeUtf8 code) rdata

-- Respond with the correct HTTP status code.
modifyResponse . setResponseCode $
case status of
Nothing -> 404
Just s -> Action.statusToHTTP s

where
fromParams :: (Monad m) => Request -> MaybeT m Request.Request
fromParams = MaybeT . return . Request.fromParams . rqParams

fromJSON :: MaybeT Snap Request.Request
fromJSON = MaybeT (Request.fromJSON <$> readRequestBody (maxBytes env))

maxBytes :: Env -> Word64
maxBytes = Request.configMaxBodySize . Config.configRequest . Env.config

--------------------------------------------------------------------------------
-- | Snap server configuration.
snapCfg :: MonadSnap m => Options -> HTTP.Config m a
snapCfg Options{..} =
HTTP.setErrorLog (HTTP.ConfigIoLog stdoutLog) $
HTTP.setAccessLog (HTTP.ConfigIoLog stdoutLog) $
HTTP.setPort optionPort $
HTTP.setBind "127.0.0.1"
HTTP.defaultConfig
where
stdoutLog :: ByteString -> IO ()
stdoutLog = ByteString.putStr . (<> "\n")

--------------------------------------------------------------------------------
-- | Run the @server@ command to receive HTTP requests.
run :: (MonadIO m) => Options -> ReaderT Env m ()
run options = do
env <- ask
liftIO $ HTTP.httpServe (snapCfg options) (site env)

Loading…
Cancel
Save