Merge pull request #2830 from urbit/king-https-fix

Get HTTPS working in King Haskell.

pkg/hs/urbit-king/lib/Urbit/Arvo/Common.hs

@@ -78,7 +78,7 @@ instance FromNoun H.StdMethod where
 
 -- Http Server Configuration ---------------------------------------------------
 
-newtype PEM = PEM { unPEM :: Cord }
+newtype PEM = PEM { unPEM :: Wain }
   deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
 
 type Key  = PEM

pkg/hs/urbit-king/lib/Urbit/Noun/Conversions.hs

@@ -8,7 +8,7 @@ module Urbit.Noun.Conversions
   , Bytes(..), Octs(..), File(..)
   , Cord(..), Knot(..), Term(..), Tape(..), Tour(..)
   , BigTape(..), BigCord(..)
-  , Wall, Each(..)
+  , Wain(..), Wall, Each(..)
   , UD(..), UV(..), UW(..), cordToUW
   , Mug(..), Path(..), EvilPath(..), Ship(..)
   , Lenient(..), pathToFilePath, filePathToPath
@@ -442,6 +442,20 @@ instance FromNoun Tape where
         Right tx -> pure (Tape tx)
 
 
+-- Wain -- List of Lines -------------------------------------------------------
+
+newtype Wain = Wain { unWain :: Text }
+  deriving newtype (Eq, Ord, Show, IsString, NFData)
+
+instance ToNoun Wain where
+  toNoun (Wain t) = toNoun (Cord <$> lines t)
+
+instance FromNoun Wain where
+  parseNoun n = named "Wain" $ do
+    tx :: [Cord] <- parseNoun n
+    pure $ Wain $ unlines (unCord <$> tx)
+
+
 -- Wall -- Text Lines ----------------------------------------------------------
 
 type Wall = [Tape]

pkg/hs/urbit-king/lib/Urbit/Vere/Http/Server.hs

@@ -33,6 +33,7 @@ import Urbit.Vere.Pier.Types
 
 import Data.Binary.Builder (Builder, fromByteString)
 import Data.Bits           (shiftL, (.|.))
+import Data.PEM            (pemParseBS, pemWriteBS)
 import Network.Socket      (SockAddr(..))
 import System.Directory    (doesFileExist, removeFile)
 import System.Random       (randomIO)
@@ -216,6 +217,9 @@ writePortsFile f = writeFile f . encodeUtf8 . portsFileText
 cordBytes :: Cord -> ByteString
 cordBytes = encodeUtf8 . unCord
 
+wainBytes :: Wain -> ByteString
+wainBytes = encodeUtf8 . unWain
+
 pass :: Monad m => m ()
 pass = pure ()
 
@@ -499,14 +503,22 @@ httpServerPorts fak = do
 
   pure (PortsToTry { .. })
 
+parseCerts :: ByteString -> Maybe (ByteString, [ByteString])
+parseCerts bs = do
+  pems <- pemParseBS bs & either (const Nothing) Just
+  case pems of
+    [] -> Nothing
+    p:ps -> pure (pemWriteBS p, pemWriteBS <$> ps)
+
 startServ :: (HasPierConfig e, HasLogFunc e, HasNetworkConfig e)
           => Bool -> HttpServerConf -> (Ev -> STM ())
           -> RIO e Serv
 startServ isFake conf plan = do
   logDebug "startServ"
 
-  let tls = hscSecure conf <&> \(PEM key, PEM cert) ->
-              (W.tlsSettingsMemory (cordBytes cert) (cordBytes key))
+  let tls = do (PEM key, PEM certs) <- hscSecure conf
+               (cert, chain)        <- parseCerts (wainBytes certs)
+               pure $ W.tlsSettingsChainMemory cert chain $ wainBytes key
 
   sId <- io $ ServId . UV . fromIntegral <$> (randomIO :: IO Word32)
   liv <- newTVarIO emptyLiveReqs

pkg/hs/urbit-king/package.yaml

@@ -67,6 +67,7 @@ dependencies:
   - network
   - optparse-applicative
   - para
+  - pem
   - pretty-show
   - primitive
   - process