Commit c3ca6b3e authored by Sophie Herold's avatar Sophie Herold 🏳🌈

Adds preliminary logger and OrdersList object

parent 8fefd752
Pipeline #882 passed with stage
in 8 minutes and 8 seconds
......@@ -61,18 +61,24 @@ obtainCertificate domains cert reactions = do
acmePerformRunner :: CragConfig -> ExceptT AcmeErr IO (CragReader, CragState)
acmePerformRunner cfg = do
manager <- newTlsManager
acmePerformRunner' manager cfg
acmePerformRunner' manager Nothing cfg
acmePerformRunner' ::
Manager -> CragConfig -> ExceptT AcmeErr IO (CragReader, CragState)
acmePerformRunner' manager cfg = do
Manager
-> Maybe (String -> IO ()) -- ^ Logger
-> CragConfig
-> ExceptT AcmeErr IO (CragReader, CragState)
acmePerformRunner' manager logger cfg = do
res <- acmePerformDirectory (cragConfigDirectoryURL cfg) manager
publicKey <- either throwError return $ jwkPublic (cragConfigJwk cfg)
return
( CragReader
cfg
CragSetup
{cragSetupJwkPublic = publicKey, cragSetupHttpManager = manager}
{ cragSetupJwkPublic = publicKey
, cragSetupHttpManager = manager
, cragSetupLogger = logger
}
, CragState
{ cragStateDirectory = res
, cragStateNonce = Nothing
......@@ -100,6 +106,10 @@ acmePerformAccountKeyRollover newJWK = do
let obj = AcmeObjAccountKeyRollover accURL newJWK
resBody =<< acmeHttpJwsPost AcmeDirectoryRequestKeyChange obj
-- | Account Orders
retrieveOrdersList :: URL -> CragT AcmeObjOrdersList
retrieveOrdersList url = resBody =<< acmeHttpGet url
-- ** Certificate
-- | Create new application (handing in a certificate request)
acmePerformNewOrder :: AcmeObjNewOrder -> CragT (URL, AcmeObjOrder)
......
......@@ -189,6 +189,7 @@ acmeHttpJwsPost' retried withKid url bod = do
-- | Perform POST query
acmeHttpPost :: URL -> AcmeJws -> CragT AcmeResponse
acmeHttpPost req bod = do
cragLog $ "POST " ++ show req
manager <- asks (cragSetupHttpManager . cragSetup)
parseResult req (Just bod') $
httpLbs
......@@ -202,6 +203,7 @@ acmeHttpGet ::
URL -- ^ Request
-> CragT AcmeResponse
acmeHttpGet req = do
cragLog $ "GET " ++ show req
manager <- asks (cragSetupHttpManager . cragSetup)
liftIO $ acmeHttpGet' req manager
......@@ -218,6 +220,7 @@ acmeHttpHead ::
URL -- ^ Request
-> CragT AcmeResponse
acmeHttpHead req = do
cragLog $ "HEAD " ++ show req
manager <- asks (cragSetupHttpManager . cragSetup)
parseResult req Nothing $ httpLbs (newHttpRequest HEAD req) manager
......
......@@ -40,9 +40,10 @@ data AcmeDirectoryMeta = AcmeDirectoryMeta
-- | Account
data AcmeObjAccount = AcmeObjAccount
{ acmeObjAccountStatus :: String
, acmeObjAccountContact :: Maybe [String]
, acmeObjAccountContact :: Maybe [URI]
, acmeObjAccountTermsOfServiceAgreed :: Maybe Bool
, acmeObjAccountOrders :: Maybe URI
, acmeObjAccountOrders :: Maybe URL
-- ^ TODO: This should not be Maybe
} deriving (Show)
-- ** New Account
......@@ -84,6 +85,11 @@ data AcmeObjNewOrder = AcmeObjNewOrder
, acmeObjNewOrderNotAfter :: Maybe ZonedTime
} deriving (Show)
-- ** Orders List
data AcmeObjOrdersList = AcmeObjOrdersList
{ acmeObjOrdersListOrders :: [URL]
}
-- ** Identifier
-- | Identifier (original ACME standard only supports type /dns/)
data AcmeObjIdentifier = AcmeObjIdentifier
......@@ -102,7 +108,6 @@ data AcmeObjAuthorization = AcmeObjAuthorization
{ acmeObjAuthorizationIdentifier :: AcmeObjIdentifier
, acmeObjAuthorizationStatus :: String
, acmeObjAuthorizationExpires :: Maybe ZonedTime
, acmeObjAuthorizationScope :: Maybe URI
, acmeObjAuthorizationChallenges :: [AcmeObjChallenge]
} deriving (Show)
......@@ -176,6 +181,7 @@ concat <$>
, ''AcmeObjIdentifier
, ''AcmeObjNewOrder
, ''AcmeObjOrder
, ''AcmeObjOrdersList
, ''AcmeObjStubAccount
, ''ProblemDetail
]
module Network.ACME.Type where
import Control.Monad.Except
import Control.Monad.Reader (ReaderT, runReaderT)
import Control.Monad.Reader (ReaderT, asks, runReaderT)
import Control.Monad.State (StateT, runStateT)
import Crypto.JOSE (JWK)
import Network.HTTP.Client (Manager)
......@@ -50,4 +50,12 @@ data CragReader = CragReader
data CragSetup = CragSetup
{ cragSetupJwkPublic :: JWK
, cragSetupHttpManager :: Manager
, cragSetupLogger :: Maybe (String -> IO ())
}
cragLog :: String -> CragT ()
cragLog msg = do
logger <- asks (cragSetupLogger . cragSetup)
case logger of
Nothing -> return ()
Just f -> liftIO $ f msg
......@@ -11,6 +11,7 @@ import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Either (isRight)
import Data.IORef
import Data.List (isInfixOf)
import Data.Maybe (fromJust, fromMaybe)
import Data.PEM (pemWriteBS)
import Data.X509 (AltName(AltNameDNS), ExtSubjectAltName(ExtSubjectAltName))
......@@ -24,6 +25,7 @@ import Data.X509.PKCS10
, toDER
, toPEM
)
import GHC.IO.Handle (hDuplicateTo, hGetLine)
import Network.Connection (TLSSettings(TLSSettingsSimple))
import Network.HTTP.Client
( Manager
......@@ -35,7 +37,8 @@ import Network.HTTP.Client.TLS (mkManagerSettings)
import Network.HTTP.Types
import Network.Wai (rawPathInfo, requestHeaders, responseLBS)
import Network.Wai.Handler.Warp
import System.Process (spawnProcess, terminateProcess)
import System.IO
import System.Process
import Test.Tasty
import Test.Tasty.HUnit
......@@ -50,25 +53,32 @@ integrationTests =
testNewAccount :: TestTree
testNewAccount =
testCase "Account operations" $ do
testCaseSteps "Account operations" $ \step -> do
(acc, jwk) <- acmeNewObjAccountStub "email1@example.org"
manager <- newUnsafeTestManager
(Right state) <- runExceptT $ acmePerformRunner' manager (config jwk)
state <- myState jwk step
flip evalCragT state $ do
_ <- acmePerformCreateAccount acc
accObj <- acmePerformCreateAccount acc
url <- acmePerformFindAccountURL
liftIO $ print url
--list <- acmeObjOrdersListOrders <$> retrieveOrdersList (acmeObjAccountOrders accObj)
--liftIO (length list @?= 0)
return ()
return ()
myState jwk step = do
manager <- newUnsafeTestManager
let logger = step
(Right state) <-
runExceptT $ acmePerformRunner' manager (Just logger) (config jwk)
return state
testOrderNew :: TestTree
testOrderNew =
testCase "Handle error" $ do
testCaseSteps "Handle error" $ \step -> do
(accStub, jwk) <- acmeNewObjAccountStub "email@example.org"
httpServerLiveConf <- newIORef []
_ <- forkIO $ myHttpServer httpServerLiveConf
manager <- newUnsafeTestManager
(Right state) <- runExceptT $ acmePerformRunner' manager (config jwk)
state <- myState jwk step
res <-
flip evalCragT state $ do
let domains = ["localhost"] --, "ip6-localhost", "ip6-loopback"]
......@@ -79,16 +89,38 @@ testOrderNew =
obtainCertificate domains cert (challengeReactions httpServerLiveConf)
liftIO $ putStrLn (concat crt :: String)
return ()
print res
isRight res @?= True
challengeReactions :: HTTPServerLiveConf -> [(String, ChallengeReaction)]
challengeReactions httpServerLiveConf =
[ ( http01
, ChallengeReaction
{ fulfill =
\identifier keyAuthz -> do
addResponse
(requestId identifier keyAuthz, keyAuthorization keyAuthz)
httpServerLiveConf
putStrLn "responded"
, rollback =
\identifier keyAuthz -> do
removeResponse (requestId identifier keyAuthz) httpServerLiveConf
putStrLn "removed"
})
]
where
requestId identifier keyAuthz =
(acmeObjIdentifierValue identifier, keyAuthorizationHttpPath keyAuthz)
pebbleResource :: TestTree -> TestTree
pebbleResource = withResource pebbleProcess terminateProcess . const
where
pebbleProcess = do
p <- spawnProcess "gopath/bin/pebble" []
-- TODO: wait for 'Pebble running'
threadDelay (2 * 1000000)
return p
stdOut <- openFile "pebble.log" WriteMode
let pr = (proc "gopath/bin/pebble" []) {std_out = UseHandle stdOut}
(_, _, _, pid) <- createProcess_ "spawnProcess" pr
threadDelay 2000000
return pid
type HTTPServerLiveConf = IORef [((String, String), String)]
......@@ -121,26 +153,6 @@ newUnsafeTestManager =
(mkManagerSettings (TLSSettingsSimple True False False) Nothing)
{managerResponseTimeout = responseTimeoutMicro 3000000}
challengeReactions :: HTTPServerLiveConf -> [(String, ChallengeReaction)]
challengeReactions httpServerLiveConf =
[ ( http01
, ChallengeReaction
{ fulfill =
\identifier keyAuthz -> do
addResponse
(requestId identifier keyAuthz, keyAuthorization keyAuthz)
httpServerLiveConf
putStrLn "responded"
, rollback =
\identifier keyAuthz -> do
removeResponse (requestId identifier keyAuthz) httpServerLiveConf
putStrLn "removed"
})
]
where
requestId identifier keyAuthz =
(acmeObjIdentifierValue identifier, keyAuthorizationHttpPath keyAuthz)
newCrt :: [String] -> IO B.ByteString
newCrt domains = do
let rsaKeySize = 256 :: Int
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment