diohsc 0.1.16 → 0.1.17
raw patch · 11 files changed
+116/−115 lines, 11 filesdep +crypton-asn1-encodingdep +crypton-asn1-typesdep +ramdep −asn1-encodingdep −asn1-typesdep −hourglassdep ~containersdep ~cryptondep ~crypton-x509
Dependencies added: crypton-asn1-encoding, crypton-asn1-types, ram, time-hourglass
Dependencies removed: asn1-encoding, asn1-types, hourglass, memory
Dependency ranges changed: containers, crypton, crypton-x509, crypton-x509-store, crypton-x509-validation, tls
Files
- ANSIColour.hs +1/−1
- CHANGELOG.md +4/−0
- ClientSessionManager.hs +8/−16
- GeminiProtocol.hs +36/−36
- Identity.hs +2/−1
- LineClient.hs +30/−28
- Makefile +1/−1
- TextGemini.hs +10/−9
- URI.hs +12/−11
- Version.hs +1/−1
- diohsc.cabal +11/−11
ANSIColour.hs view
@@ -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'
CHANGELOG.md view
@@ -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.
ClientSessionManager.hs view
@@ -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
GeminiProtocol.hs view
@@ -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"
Identity.hs view
@@ -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
LineClient.hs view
@@ -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
Makefile view
@@ -1,4 +1,4 @@-VERSION=0.1.16+VERSION=0.1.17 GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa
TextGemini.hs view
@@ -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 }
URI.hs view
@@ -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
Version.hs view
@@ -16,4 +16,4 @@ programName = "diohsc" version :: String-version = "0.1.16"+version = "0.1.17"
diohsc.cabal view
@@ -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