diff --git a/ANSIColour.hs b/ANSIColour.hs --- a/ANSIColour.hs +++ b/ANSIColour.hs @@ -163,7 +163,7 @@ stripControl :: T.Text -> T.Text stripControl = T.concatMap $ \case '\t' -> " " - c | wcwidth c == 0 -> "" + c | wcwidth c <= 0 -> "" c -> T.singleton c -- |strip all C0 and C1 control chars except '\t' diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,10 @@ This file covers only non-trivial user-visible changes; see the git log for full gory details. +# 0.1.17 +* Match port as well as host for session resumption +* Interpret backslash-escapes when setting client cert CN + # 0.1.16 * Fix producing client certificates with illegal empty CN. Instead, use "OU=-" as DN if CN is empty. diff --git a/ClientSessionManager.hs b/ClientSessionManager.hs --- a/ClientSessionManager.hs +++ b/ClientSessionManager.hs @@ -26,32 +26,24 @@ import qualified Data.Map as Map import Fingerprint +import Request -type ClientSessions = MVar (Map.Map (HostName, Maybe Fingerprint) (Elapsed, (SessionID, SessionData))) +type ClientSessions = MVar (Map.Map (Host, Maybe Fingerprint) (Elapsed, (SessionID, SessionData))) newClientSessions :: IO ClientSessions newClientSessions = newMVar Map.empty -clientSessionManager :: Int -> ClientSessions -> Maybe Fingerprint -> SessionManager -clientSessionManager lifetime sess fp = noSessionManager - { sessionResume = \_ -> return Nothing - , sessionResumeOnlyOnce = \_ -> return Nothing - , sessionEstablish = insert - , sessionInvalidate = delete - , sessionUseTicket = True - } +clientSessionManager :: Int -> ClientSessions -> Host -> Maybe Fingerprint -> SessionManager +clientSessionManager lifetime sess host fp = noSessionManager { sessionEstablish = insert } where - insert sid sd | Just sni <- sessionClientSNI sd = do + insert sid sd | Just (hostName host) == sessionClientSNI sd = do now <- timeCurrent let expire = now `timeAdd` Seconds (fromIntegral lifetime) modifyMVar_ sess $ return . - Map.insert (sni, fp) (expire,(sid,sd)) . + Map.insert (host, fp) (expire,(sid,sd)) . fromAscList . filter (\(_,(t,(_,_))) -> t >= now) . toAscList return Nothing insert _ _ = return Nothing - delete sid = - modifyMVar_ sess $ return . - fromAscList . filter (\(_,(_,(sid',_))) -> sid /= sid') . toAscList -lookupClientSession :: HostName -> Maybe Fingerprint -> ClientSessions -> IO (Maybe (SessionID, SessionData)) -lookupClientSession sni fp sess = (snd <$>) . Map.lookup (sni,fp) <$> readMVar sess +lookupClientSession :: Host -> Maybe Fingerprint -> ClientSessions -> IO (Maybe (SessionID, SessionData)) +lookupClientSession host fp sess = (snd <$>) . Map.lookup (host,fp) <$> readMVar sess diff --git a/GeminiProtocol.hs b/GeminiProtocol.hs --- a/GeminiProtocol.hs +++ b/GeminiProtocol.hs @@ -81,7 +81,8 @@ showMimeType = TS.unpack . MIME.showMIMEType . MIME.mimeType . mimedMimetype data ResponseMalformation - = BadHeaderTermination + = NullResponse + | BadHeaderTermination | BadStatus String | BadMetaSeparator | BadMetaLength @@ -179,15 +180,15 @@ -> Bool -- ^whether to display extra information about connection -> Request -> IO (Either SomeException (Response, IO ())) makeRequest (RequestContext (InteractionCallbacks displayInfo displayWarning _ promptYN) - certStore mTrusted mIgnoredCertErrors mWarnedCA mIgnoredCCertWarnings serviceCertsPath readOnly socksProxy clientSessions) mIdent bound verboseConnection (NetworkRequest (Host hostname port) uri) = + certStore mTrusted mIgnoredCertErrors mWarnedCA mIgnoredCCertWarnings serviceCertsPath readOnly socksProxy clientSessions) mIdent bound verboseConnection (NetworkRequest host@(Host hostname port) uri) = let requestBytes = TS.encodeUtf8 . TS.pack $ show uri ++ "\r\n" uriLength = BS.length requestBytes - 2 ccfp = clientCertFingerprint . identityCert <$> mIdent in if uriLength > 1024 then return . Left . toException $ ExcessivelyLongUri uriLength else handle handleAll $ do - session <- lookupClientSession hostname ccfp clientSessions + session <- lookupClientSession host ccfp clientSessions let serverId = if port == defaultGeminiPort then BS.empty else TS.encodeUtf8 . TS.pack . (':':) $ show port - sessionManager = clientSessionManager 3600 clientSessions ccfp + sessionManager = clientSessionManager 3600 clientSessions host ccfp params = (TLS.defaultParamsClient hostname serverId) { clientSupported = def { supportedCiphers = gemini_ciphersuite @@ -376,17 +377,16 @@ ": " ++ printExpiry trustedCert ] signedByOld = X.SignaturePass `elem` ((`X.verifySignedSignature` X.certPubKey trustedCert) <$> signedCerts) - if signedByOld - then displayInfo $ + case () of + _ | signedByOld -> displayInfo $ ("The new certificate chain is signed by " ++ (if expired then "an EXPIRED" else "a") ++ " key previously trusted for this host.") : oldInfo - else if expired || samePubKey - then displayInfo $ + _ | expired || samePubKey -> displayInfo $ ("A different " ++ (if expired then "expired " else "non-expired ") ++ "certificate " ++ (if samePubKey then "with the same public key " else "") ++ "for " ++ serviceString ++ " was previously explicitly trusted.") : oldInfo - else displayWarning $ + _ -> displayWarning $ ("CAUTION: A certificate with a different public key for " ++ serviceString ++ " was previously explicitly trusted and has not expired!") : oldInfo when (tempTimes > 0) $ displayInfo [ @@ -466,24 +466,24 @@ gemini_ciphersuite :: [Cipher] gemini_ciphersuite = [ -- First the PFS + GCM + SHA2 ciphers - cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES256GCM_SHA384 - , cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 - , cipher_ECDHE_RSA_AES128GCM_SHA256, cipher_ECDHE_RSA_AES256GCM_SHA384 - , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 + cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256, cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 + , cipher_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 + , cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256, cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 + , cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 --, cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES256GCM_SHA384 --, cipher_DHE_RSA_CHACHA20POLY1305_SHA256 , -- Next the PFS + CCM + SHA2 ciphers - cipher_ECDHE_ECDSA_AES128CCM_SHA256, cipher_ECDHE_ECDSA_AES256CCM_SHA256 + cipher_ECDHE_ECDSA_WITH_AES_128_CCM, cipher_ECDHE_ECDSA_WITH_AES_256_CCM --, cipher_DHE_RSA_AES128CCM_SHA256, cipher_DHE_RSA_AES256CCM_SHA256 -- Next the PFS + CBC + SHA2 ciphers --, cipher_ECDHE_ECDSA_AES128CBC_SHA256, cipher_ECDHE_ECDSA_AES256CBC_SHA384 --, cipher_ECDHE_RSA_AES128CBC_SHA256, cipher_ECDHE_RSA_AES256CBC_SHA384 --, cipher_DHE_RSA_AES128_SHA256, cipher_DHE_RSA_AES256_SHA256 -- TLS13 (listed at the end but version is negotiated first) - , cipher_TLS13_AES128GCM_SHA256 - , cipher_TLS13_AES256GCM_SHA384 - , cipher_TLS13_CHACHA20POLY1305_SHA256 - , cipher_TLS13_AES128CCM_SHA256 + , cipher13_AES_128_GCM_SHA256 + , cipher13_AES_256_GCM_SHA384 + , cipher13_CHACHA20_POLY1305_SHA256 + , cipher13_AES_128_CCM_SHA256 ] parseResponse :: BL.ByteString -> Response @@ -493,23 +493,23 @@ statusString = T.unpack . stripControl . T.decodeUtf8 . BL.take 2 $ header separator = BL.take 1 . BL.drop 2 $ header meta = T.unpack . stripControl . T.decodeUtf8 . BL.drop 3 $ header - in - if BL.take 2 rest /= "\r\n" then MalformedResponse BadHeaderTermination - else if separator `notElem` [""," ","\t"] -- ^allow \t for now, though it's against latest spec - then MalformedResponse BadMetaSeparator - else if BL.length header > 1024+3 then MalformedResponse BadMetaLength - else case readMay statusString of - Just status | status >= 10 && status < 70 -> - let (status1,status2) = divMod status 10 - in case status1 of - 1 -> Input (status2 == 1) meta - 2 -> maybe (MalformedResponse (BadMime meta)) - (\mime -> Success $ MimedData mime body) $ - MIME.parseMIMEType (TS.pack $ - if null meta then "text/gemini; charset=utf-8" else meta) - 3 -> maybe (MalformedResponse (BadUri meta)) - (Redirect (status2 == 1)) $ parseUriReference meta - _ -> Failure status meta - _ -> MalformedResponse (BadStatus statusString) + in case () of + _ | BL.null resp -> MalformedResponse NullResponse + _ | BL.take 2 rest /= "\r\n" -> MalformedResponse BadHeaderTermination + _ | separator `notElem` [""," ","\t"] -- ^allow \t for now, though it's against latest spec + -> MalformedResponse BadMetaSeparator + _ | BL.length header > 1024+3 -> MalformedResponse BadMetaLength + _ | Just status <- readMay statusString, status >= 10 && status < 70 -> + let (status1,status2) = divMod status 10 + in case status1 of + 1 -> Input (status2 == 1) meta + 2 -> maybe (MalformedResponse (BadMime meta)) + (\mime -> Success $ MimedData mime body) $ + MIME.parseMIMEType (TS.pack $ + if null meta then "text/gemini; charset=utf-8" else meta) + 3 -> maybe (MalformedResponse (BadUri meta)) + (Redirect (status2 == 1)) $ parseUriReference meta + _ -> Failure status meta + _ -> MalformedResponse (BadStatus statusString) makeRequest _ _ _ _ (LocalFileRequest _) = error "File requests not handled by makeRequest" diff --git a/Identity.hs b/Identity.hs --- a/Identity.hs +++ b/Identity.hs @@ -26,6 +26,7 @@ import MetaString import Mundanities import Prompt +import URI data Identity = Identity { identityName :: String, identityCert :: ClientCert } deriving (Eq,Show) @@ -66,7 +67,7 @@ putStrLn $ "We will refer to it as " <> showIdentityName ansi idName <> ", but you may also set a \"Common Name\";" putStrLn "this is recorded in the identity certificate, and may be interpreted by the server as a username." putStrLn "The common name may be left blank. Use ^C to cancel identity generation." - clientCert <- liftIO . generateSelfSigned tp . fromMaybe "" =<< + clientCert <- liftIO . generateSelfSigned tp . maybe "" escapeInput =<< if not interactive then return Nothing else MaybeT (promptLine "Common Name: ") liftIO $ mkdirhier idsPath lift $ saveClientCert idsPath idName clientCert diff --git a/LineClient.hs b/LineClient.hs --- a/LineClient.hs +++ b/LineClient.hs @@ -114,11 +114,9 @@ lineClient' = do cmd <- lift getPrompt >>= promptLineInputT quit <- case cmd of - Nothing -> if interactive - then printErrFancy ansi "Use \"quit\" to quit" >> return False - else return True - Just Nothing -> return True + Nothing | interactive -> printErrFancy ansi "Use \"quit\" to quit" >> return False Just (Just line) -> handleLine' line + _ -> return True lift addToQueuesFromFiles unless quit lineClient' @@ -178,15 +176,14 @@ in "[" ++ (if abbrId then ".." ++ take 6 idName else idName) ++ "]" abbrUri = length fullUriStr + length idStr > w - 2 uriFormat = colour BoldMagenta - uriStr = if abbrUri - then + uriStr | abbrUri = let abbrUriChars = w - 4 - length idStr preChars = abbrUriChars `div` 2 postChars = abbrUriChars - preChars in uriFormat (take preChars fullUriStr) <> ".." <> uriFormat (drop (length fullUriStr - postChars) fullUriStr) - else uriFormat fullUriStr + | otherwise = uriFormat fullUriStr in uriStr ++ (if null idStr then "" else colour Green idStr) prompt :: Int -> String @@ -290,11 +287,12 @@ handled = scheme `elem` ["gemini","file"] || M.member scheme proxies inHistory = isJust $ curr >>= flip pathItemByUri uri activeId = isJust $ idAtUri ais uri - col = if inHistory && not activeId then BoldBlue else case (isVisited uri,handled) of - (True,True) -> Yellow - (False,True) -> BoldYellow - (True,False) -> Red - (False,False) -> BoldRed + col | inHistory && not activeId = BoldBlue + | otherwise = case (isVisited uri,handled) of + (True,True) -> Yellow + (False,True) -> BoldYellow + (True,False) -> Red + (False,False) -> BoldRed s = case base of Nothing -> show uri Just b -> show $ relativeFrom uri b @@ -353,8 +351,9 @@ handle printIOErr $ saveMark marksDir mark uriId setMark mark _ = printErr $ "Invalid mark name " ++ mark - promptInput = if ghost then promptLine else promptLineWithHistoryFile inputHistPath - where inputHistPath = userDataDir "inputHistory" + promptInput + | ghost = promptLine + | otherwise = promptLineWithHistoryFile $ userDataDir "inputHistory" handleCommandLine' :: Maybe PTarget -> Maybe (String, [CommandArg]) -> ClientM () handleCommandLine' mt mcas = void . runMaybeT $ do @@ -422,9 +421,10 @@ ais <- gets clientActiveIdentities let showNumberedUri :: Bool -> T.Text -> (Int,URI) -> T.Text showNumberedUri iter s (n,uri) = s <> - (if iter && n == 1 then " " - else if iter && n == 2 then T.takeEnd 1 s - else T.pack (show n)) <> + (case () of + _ | iter && n == 1 -> " " + _ | iter && n == 2 -> T.takeEnd 1 s + _ -> T.pack (show n)) <> " " <> showUriFull ansi ais Nothing uri showIteratedItem s (n,item) = showNumberedUri True s (n, historyUri item) showNumberedItem s (n,item) = showNumberedUri False s (n, historyUri item) @@ -607,9 +607,8 @@ CommandArg ('e':'d':_) _ : _ -> KeyEd25519 _ -> KeyRSA in getIdentity interactive ansi idsPath tp idName - [] -> if interactive - then getIdentityRequesting ansi idsPath - else getIdentity interactive ansi idsPath KeyRSA "" + _ | interactive -> getIdentityRequesting ansi idsPath + _ -> getIdentity interactive ansi idsPath KeyRSA "" lift $ addIdentity req ident handleUriCommand uri ("browse", args) = do ais <- gets clientActiveIdentities @@ -781,10 +780,10 @@ doRequestUri' redirs uri | Just req <- requestOfUri uri = addToLog uri >> doRequest redirs req | otherwise = printErr $ "Bad URI: " ++ displayUri uri ++ ( - let scheme = uriScheme uri - in if scheme /= "gemini" && isNothing (M.lookup scheme proxies) - then " : No proxy set for non-gemini scheme " ++ scheme ++ "; use \"browse\"?" - else "") + case uriScheme uri of + "gemini" -> "" + scheme | Just _ <- M.lookup scheme proxies -> "" + scheme -> " : No proxy set for non-gemini scheme " ++ scheme ++ "; use \"browse\"?") doRequest :: Int -> Request -> ClientM () doRequest redirs _ | redirs > 5 = @@ -839,7 +838,10 @@ liftIO . putStrLn $ (case code of 60 -> "Server requests identification" _ -> "Server rejects provided identification certificate" ++ - (if code == 61 then " as unauthorised" else if code == 62 then " as invalid" else "")) + (case code of + 61 -> " as unauthorised" + 62 -> " as invalid" + _ -> "")) ++ if null info then "" else ": " ++ info guard interactive MaybeT . liftIO $ getIdentityRequesting ansi idsPath @@ -938,9 +940,9 @@ "Warning: Treating unsupported charset " ++ show charset ++ " as utf-8" #endif (_,width) <- getTermSize - let pageWidth = if interactive - then min maxWrapWidth (width - 4) - else maxWrapWidth + let pageWidth + | interactive = min maxWrapWidth (width - 4) + | otherwise = maxWrapWidth let bodyText = T.decodeUtf8With T.lenientDecode $ reencoder body applyFilter :: [T.Text] -> IO [T.Text] applyFilter = case renderFilter of diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -VERSION=0.1.16 +VERSION=0.1.17 GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa diff --git a/TextGemini.hs b/TextGemini.hs --- a/TextGemini.hs +++ b/TextGemini.hs @@ -115,16 +115,17 @@ maxWCWidth = 2 ww = max maxWCWidth wrapWidth wrap' ls l _ [] = [ls <> [l] ] - wrap' ls l n (w:ws) = - let nw = visibleLength w - l' = if T.null l then w else l <> " " <> w + wrap' ls l n (w:ws) + | nw > ww && n + 1 < ww = + let (a,b) = splitAtVisible ww l' + in wrap' (ls <> [a]) "" 0 $ b:ws + | n' > ww = (ls <> [l]:) $ wrap' [] "" 0 $ w:ws + | otherwise = wrap' ls l' n' ws + where + nw = visibleLength w + l' | T.null l = w + | otherwise = l <> " " <> w n' = n + nw + (if T.null l then 0 else 1) - in if nw > ww && n + 1 < ww - then let (a,b) = splitAtVisible ww l' - in wrap' (ls <> [a]) "" 0 $ b:ws - else if n' > ww - then (ls <> [l]:) $ wrap' [] "" 0 $ w:ws - else wrap' ls l' n' ws data GeminiParseState = GeminiParseState { numLinks :: Int, preformatted :: Maybe T.Text } diff --git a/URI.hs b/URI.hs --- a/URI.hs +++ b/URI.hs @@ -16,6 +16,7 @@ , URIRef , escapeIRI , escapePathString + , escapeInput , escapeQuery , escapeQueryPart , nullUri @@ -163,17 +164,17 @@ isUnescapedInQuery :: Char -> Bool isUnescapedInQuery c = NU.isUnescapedInURI c && c `notElem` ("#[]"::String) -escapeQuery :: String -> String -escapeQuery = NU.escapeURIString isUnescapedInQuery . withEscapes - where - withEscapes "" = "" - withEscapes ('\\':'x':h1:h2:s) | Just c <- readMay $ "'\\x" <> [h1,h2,'\''] = c:withEscapes s - withEscapes ('\\':'e':s) = '\ESC':withEscapes s - withEscapes ('\\':'r':s) = '\r':withEscapes s - withEscapes ('\\':'n':s) = '\n':withEscapes s - withEscapes ('\\':'t':s) = '\t':withEscapes s - withEscapes ('\\':c:s) = c:withEscapes s - withEscapes (c:s) = c:withEscapes s +escapeQuery, escapeInput :: String -> String +escapeQuery = NU.escapeURIString isUnescapedInQuery . escapeInput + +escapeInput "" = "" +escapeInput ('\\':'x':h1:h2:s) | Just c <- readMay $ "'\\x" <> [h1,h2,'\''] = c:escapeInput s +escapeInput ('\\':'e':s) = '\ESC':escapeInput s +escapeInput ('\\':'r':s) = '\r':escapeInput s +escapeInput ('\\':'n':s) = '\n':escapeInput s +escapeInput ('\\':'t':s) = '\t':escapeInput s +escapeInput ('\\':c:s) = c:escapeInput s +escapeInput (c:s) = c:escapeInput s -- |escape the query part of an unparsed uri string escapeQueryPart :: String -> String diff --git a/Version.hs b/Version.hs --- a/Version.hs +++ b/Version.hs @@ -16,4 +16,4 @@ programName = "diohsc" version :: String -version = "0.1.16" +version = "0.1.17" diff --git a/diohsc.cabal b/diohsc.cabal --- a/diohsc.cabal +++ b/diohsc.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: diohsc -version: 0.1.16 +version: 0.1.17 license: GPL-3 license-file: COPYING maintainer: mbays@sdf.org @@ -89,21 +89,21 @@ ghc-options: -threaded -Wall build-depends: base >=4.3 && <5, - asn1-encoding <0.10, - asn1-types >=0.3.4 && <0.4, + crypton-asn1-encoding >= 0.10 && <0.11, + crypton-asn1-types >=0.4.0 && <0.5, bytestring >=0.10.4.0 && <0.13, - containers >=0.5.5.1 && <0.8, - crypton >=0.26 && <1.1, + containers >=0.5.5.1 && <0.9, + crypton >=1.0.7 && <1.2, data-default-class >=0.1.2.0 && <0.3, hashable >= 1.1 && <1.6, directory >=1.2.1.0 && <1.4, exceptions >=0.10.4 && <0.11, filepath >=1.3.0.2 && <1.6, haskeline ==0.8.*, - hourglass >=0.2.12 && <0.3, + time-hourglass >=0.2.12 && <0.4, mime >=0.4.0.2 && <0.5, mtl >=2.1.3.1 && <2.4, - memory >=0.14 && <0.19, + ram >=0.14 && <0.23, network >=2.4.2.3 && <3.3, network-simple >=0.4.3 && <0.5, network-uri >=2.6.3.0 && <2.8, @@ -116,11 +116,11 @@ temporary ==1.3.*, terminal-size >=0.3.2.1 && <0.4, text >=1.1.0.0 && <2.2, - tls >=2.0 && <2.2, + tls >=2.3 && <2.5, transformers >=0.3.0.0 && <0.7, - crypton-x509 >=1.7.5 && <1.8, - crypton-x509-store >=1.6.7 && <1.7, - crypton-x509-validation >=1.6.11 && <1.7 + crypton-x509 >=1.9.0 && <1.10, + crypton-x509-validation >=1.9.0 && <1.10, + crypton-x509-store >=1.9.0 && <1.10 if os(windows) cpp-options: -DWINDOWS