Exploratory venture into using templates

.gitignore

@@ -0,0 +1,38 @@
+# Haskell
+.conf
+*.o
+*.hi
+*.chi
+*.chs.h
+*.imports
+
+# Dirs
+cabal-dev
+bin
+dist
+tmp
+.shelly
+vendor
+
+# CTAGS
+TAGS
+tags
+
+# Emacs/Vim
+*~
+*#
+.#*
+\#*#
+.*.sw[a-z]
+*.un~
+*.org
+
+# OSX
+.DS_Store
+
+# Keiretsu
+.env
+Procfile
+
+# Protobufs
+Protocol*

Makefile

@@ -0,0 +1,18 @@
+all: build
+
+build: .conf
+	cabal-dev build
+
+install:
+	cabal-dev install -j \
+	 --disable-documentation \
+	 --disable-library-coverage
+
+clean:
+	-rm -rf .conf bin dist .shelly
+
+lint:
+	hlint src
+
+.conf:
+	cabal-dev configure && touch .conf

Setup.hs

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

haws.cabal

@@ -0,0 +1,79 @@
+name:                  haws
+version:               0.1.0
+synopsis:              Pending
+license:               OtherLicense
+license-file:          LICENSE
+author:                Brendan Hay
+maintainer:            Brendan Hay <[email protected]>
+copyright:             Copyright (c) 2013 Brendan Hay
+stability:             Experimental
+category:              Network
+build-type:            Simple
+cabal-version:         >= 1.10
+
+extra-source-files:
+    README.md
+
+data-files:
+    template/route53/create_health_check
+
+description:
+    Pending
+
+library
+    default-language:  Haskell2010
+    hs-source-dirs:    src
+
+    exposed-modules:
+        Paths_haws
+
+        Network.AWS.Route53
+
+    other-modules:
+
+    ghc-options:
+        -Wall
+        -rtsopts
+        -fwarn-tabs
+        -funbox-strict-fields
+
+    build-depends:
+        aeson
+      , base                 >= 4 && < 5
+      , base64-bytestring
+      , bytestring
+      , containers
+      , hastache
+      , http-streams
+      , http-types
+      , hxt
+      , hxt-expat
+      , hxt-tagsoup
+      , io-streams
+      , mtl
+      , old-locale
+      , regex-posix
+      , SHA
+      , text
+      , time
+      , transformers
+      , unordered-containers
+      , vector
+
+-- executable haws
+--     default-language:  Haskell2010
+--     main-is:           Main.hs
+--     hs-source-dirs:    src
+
+--     ghc-options:
+--         -threaded
+--         -Wall
+--         -fwarn-tabs
+--         -funbox-strict-fields
+--         -with-rtsopts=-N
+--         -with-rtsopts=-T
+
+--     build-depends:
+--         base >= 4 && < 5
+--       , haws
+--       , hastache

src/Main.hs

@@ -0,0 +1,17 @@
+-- |
+-- Module      : Main
+-- Copyright   : (c) 2013 Brendan Hay <[email protected]>
+-- License     : This Source Code Form is subject to the terms of
+--               the Mozilla Public License, v. 2.0.
+--               A copy of the MPL can be found in the LICENSE file or
+--               you can obtain it at http://mozilla.org/MPL/2.0/.
+-- Maintainer  : Brendan Hay <[email protected]>
+-- Stability   : experimental
+-- Portability : non-portable (GHC extensions)
+
+module Main where
+
+import qualified Network.AWS.Route53 as Route53
+
+main :: IO ()
+main = return ()

src/Network/AWS/Request.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module      : Network.AWS.Request
+-- Copyright   : (c) 2013 Brendan Hay <[email protected]>
+-- License     : This Source Code Form is subject to the terms of
+--               the Mozilla Public License, v. 2.0.
+--               A copy of the MPL can be found in the LICENSE file or
+--               you can obtain it at http://mozilla.org/MPL/2.0/.
+-- Maintainer  : Brendan Hay <[email protected]>
+-- Stability   : experimental
+-- Portability : non-portable (GHC extensions)
+
+module Network.AWS.Request where
+
+import           Data.ByteString        (ByteString)
+import qualified Data.ByteString.Char8  as BS
+import qualified Data.ByteString.Base64 as Base64
+import qualified Data.ByteString.Lazy   as LBS
+import qualified Data.Digest.Pure.SHA   as SHA
+import           Data.List
+import           Data.Monoid
+import           Data.Time              (UTCTime, formatTime, getCurrentTime)
+import qualified Network.HTTP.Types     as HTTP
+import           Network.Http.Client
+import           System.Locale          (defaultTimeLocale, iso8601DateFormat)
+
+type Endpoint  = ByteString
+type Action    = ByteString
+type Path      = ByteString
+type Version   = ByteString
+
+data Credentials = Credentials
+    { accessKey :: ByteString
+    , secretKey :: ByteString
+    } deriving (Show)
+
+version2 :: Method
+         -> Endpoint
+         -> Action
+         -> Credentials
+         -> Version
+         -> [(ByteString, ByteString)]
+         -> IO Request
+version2 meth end action creds ver params = do
+    time <- getCurrentTime
+    buildRequest . http meth
+        $ "/?" <> query time <> "&Signature=" <> signature time
+  where
+    signature time = HTTP.urlEncode True
+        . Base64.encode
+        . LBS.toStrict
+        . SHA.bytestringDigest
+        . SHA.hmacSha256 (LBS.fromStrict $ secretKey creds)
+        . LBS.fromStrict
+        $ BS.intercalate "\n" [packMethod meth, end, action, query time]
+
+    query time = queryString $ params `union`
+        [ ("Action", action)
+        , ("Version", ver)
+        , ("SignatureVersion", "2")
+        , ("SignatureMethod", "HmacSHA256")
+        , ("Timestamp", timeFormat time)
+        , ("AWSAccessKeyId", accessKey creds)
+        ]
+
+version3 :: Method
+         -> Endpoint
+         -> Path
+         -> Credentials
+         -> [(ByteString, ByteString)]
+         -> IO Request
+version3 meth end path creds params = do
+    time <- getCurrentTime
+    buildRequest $ do
+        http meth $ path <> "/?" <> query
+        setHeader "X-Amzn-Authorization" $ authorization time
+  where
+    query = queryString $ ("AWSAccessKeyId", accessKey creds) : params
+
+    authorization time = mconcat
+        [ "AWS3-HTTPS AWSAccessKeyId="
+        , accessKey creds
+        , ", Algorithm=HmacSHA256, Signature="
+        , signature time
+        ]
+
+    signature = LBS.toStrict
+        . SHA.bytestringDigest
+        . SHA.hmacSha256 (LBS.fromStrict $ secretKey creds)
+        . LBS.fromStrict
+        . timeFormat
+
+packMethod :: Method -> ByteString
+packMethod = BS.pack . show
+
+queryString :: [(ByteString, ByteString)] -> ByteString
+queryString = BS.intercalate "&" . map concatEq . sort
+  where
+    concatEq (k, v) = mconcat [k, "=", HTTP.urlEncode True v]
+
+timeFormat :: UTCTime -> ByteString
+timeFormat = BS.pack . formatTime defaultTimeLocale fmt
+  where
+    fmt = iso8601DateFormat $ Just "%XZ"

src/Network/AWS/Route53.hs

@@ -0,0 +1,108 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE RecordWildCards            #-}
+
+-- |
+-- Module      : Network.AWS.Route53
+-- Copyright   : (c) 2013 Brendan Hay <[email protected]>
+-- License     : This Source Code Form is subject to the terms of
+--               the Mozilla Public License, v. 2.0.
+--               A copy of the MPL can be found in the LICENSE file or
+--               you can obtain it at http://mozilla.org/MPL/2.0/.
+-- Maintainer  : Brendan Hay <[email protected]>
+-- Stability   : experimental
+-- Portability : non-portable (GHC extensions)
+
+module Network.AWS.Route53 where
+
+import           Control.Applicative
+import           Control.Monad
+import           Control.Monad.IO.Class
+import           Control.Monad.Reader
+import           Data.Aeson
+import           Data.ByteString        (ByteString)
+import qualified Data.ByteString        as BS
+import qualified Data.ByteString.Lazy   as LBS
+import           Data.Data
+import           Data.Maybe
+import           Data.Monoid
+import           Data.Time
+import           GHC.Word
+import           Network.AWS.Request
+import           Network.Http.Client
+import           Paths_haws             (getDataFileName)
+import           System.IO.Streams      (InputStream, OutputStream, stdout)
+import qualified System.IO.Streams      as Streams
+import           Text.Hastache
+import           Text.Hastache.Context
+
+class (Data a, Typeable a) => AWSRequest a where
+    rqTemplate :: a -> FilePath
+    rqUri      :: a -> ByteString
+
+data CreateHealthCheck = CreateHealthCheck
+    { chcCallerRef :: String
+    , chcIpAddress :: String
+    , chcPort      :: Word16
+    , chcProtocol  :: String
+    , chcResource  :: String
+    , chcFQDN      :: String
+    } deriving (Data, Typeable)
+
+data Signed = Signed
+    { sigMethod       :: Method
+    , sigUri          :: ByteString
+    , sigDate         :: Maybe UTCTime
+    , sigAuth         :: Maybe ByteString
+    , sigContentType  :: Maybe ByteString
+    , sigContentMD5   :: Maybe MD5.MD5
+    , sigAWSHeaders   :: HTTP.RequestHeaders
+    , sigHeaders      :: HTTP.RequestHeaders
+    , sigBody         :: Maybe ByteString
+    , sigStringToSign :: ByteString
+    } deriving (Show)
+
+newtype AWS a = AWS { unWrap :: ReaderT Credentials IO a }
+    deriving (Functor, Applicative, Monad, MonadIO, MonadPlus, MonadReader Credentials)
+
+runAWS :: Credentials -> AWS a -> IO a
+runAWS creds aws = runReaderT (unWrap aws) creds
+
+-- FIXME: Use template haskell for instances
+-- Function which determines the template from the class name underscored
+-- and takes the uri as an argument
+instance AWSRequest CreateHealthCheck where
+    requestTemplate _ = "create_health_check"
+    request  _ = route53Base <> "healthcheck"
+    signingVersion _ =
+
+route53Base :: ByteString
+route53Base = "https://route53.amazonaws.com/doc/2012-12-12/"
+
+awsRequest :: AWSRequest a => a -> AWS ()
+awsRequest rq = do
+    Credentials{..} <- ask
+    liftIO $ request' rq
+
+request' :: AWSRequest a => a -> IO ()
+request' rq = do
+    c <- openConnection (requestUri rq) 80
+    q <- buildRequest $ do
+        http GET "/"
+        setAccept "text/html"
+
+    bodyStream >>= sendRequest c q . inputStreamBody
+
+    receiveResponse c (\p i -> do
+        x <- Streams.read i
+        BS.putStr $ fromMaybe "" x)
+
+    closeConnection c
+  where
+    bodyStream = do
+       t <- readTemplate $ requestTmpl rq
+       b <- hastacheStr defaultConfig t $ mkGenericContext rq
+       Streams.makeInputStream . return . Just $ LBS.toStrict b
+
+    readTemplate = (BS.readFile =<<) . getDataFileName

template/route53/create_health_check

@@ -0,0 +1,11 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CreateHealthCheckRequest xmlns="https://route53.amazonaws.com/doc/2012-12-12/">
+  <CallerReference>{{chcCallerRef}}</CallerReference>
+  <HealthCheckConfig>
+    <IPAddress>{{chcIpAddress}}</IPAddress>
+    <Port>{{chcPort}}</Port>
+    <Type>{{chcProtocol}}</Type>
+    <ResourcePath>{{chcResource}}</ResourcePath>
+    <FullyQualifiedDomainName>{{chcFQDN}}</FullyQualifiedDomainName>
+  </HealthCheckConfig>
+</CreateHealthCheckRequest>