add httponly support to cookies.txt saving

use bytestring for cookie storage

Bind.hs

@@ -48,7 +48,7 @@ search rev s = run $ "search" ++ (if rev then "_reverse" else "") ++ ' ' : escap
 
 cookieSave :: UzblM ()
 cookieSave = do
-  io . saveCookies (uzblHome "cookies.save") . uzblCookies =<< get
+  io . saveCookiesTxt (uzblHome "cookies.txt") . uzblCookies =<< get
   status "cookies saved"
 
 promptComplete :: String -> String -> (String -> UzblM (Maybe String)) -> (String -> UzblM ()) -> UzblM ()

Cookies.hs

@@ -3,14 +3,15 @@ module Cookies
   , cookieDomain
   , Cookies
   , emptyCookies
-  , loadCookies, loadElinksCookies
-  , saveCookies
+  , loadCookiesTxt, loadElinksCookies
+  , saveCookiesTxt
   , cookiesArgs
   , argCookie
   , cookieAdd
   ) where
 
 import Control.Monad
+import qualified Data.ByteString.Char8 as BS
 import Data.Function
 import Data.List
 import Data.Maybe
@@ -23,8 +24,9 @@ import Safe
 import Util
 
 data Cookie = Cookie
-  { cookieDomain, cookiePath, cookieName, cookieValue :: String
+  { cookieDomain, cookiePath, cookieName, cookieValue :: BS.ByteString
   , cookieSecure :: Bool
+  , cookieHttpOnly :: Bool
   , cookieExpire :: Maybe POSIXTime
   } deriving (Eq, Show)
 
@@ -39,34 +41,37 @@ emptyCookies = Set.empty
 parseElinksCookie :: String -> Maybe Cookie
 parseElinksCookie = pec . splitOn ('\t'==) where
   pec [name, value, _server, path, domain, expire, secure] = Just $ Cookie
-    { cookieDomain = '.':domain
-    , cookiePath = path
-    , cookieName = name
-    , cookieValue = value
+    { cookieDomain = BS.pack $ '.':domain
+    , cookiePath = BS.pack $ path
+    , cookieName = BS.pack $ name
+    , cookieValue = BS.pack $ value
     , cookieSecure = secure /= "0"
+    , cookieHttpOnly = False
     , cookieExpire = fmap fromInteger $ readMay expire
     }
   pec _ = Nothing
 
-parseCookie :: String -> Maybe Cookie
-parseCookie = pc . splitOn ('\t'==) where
+parseCookieTxt :: String -> Maybe Cookie
+parseCookieTxt = pc . splitOn ('\t'==) where
   pc [domain, _flag, path, secure, expire, name, value] = Just $ Cookie
-    { cookieDomain = domain
-    , cookiePath = path
-    , cookieName = name
-    , cookieValue = value
+    { cookieDomain = BS.pack $ fromMaybe domain hod
+    , cookiePath = BS.pack $ path
+    , cookieName = BS.pack $ name
+    , cookieValue = BS.pack $ value
     , cookieSecure = secure `notElem` ["FALSE","0"]
+    , cookieHttpOnly = isJust hod
     , cookieExpire = fmap fromInteger $ readMay expire
-    }
+    } where hod = stripPrefix "#HttpOnly_" domain
   pc _ = Nothing
 
 argCookie :: [String] -> Maybe Cookie
 argCookie [domain,path,name,value,scheme,expire] = Just $ Cookie
-  { cookieDomain = domain
-  , cookiePath = path
-  , cookieName = name
-  , cookieValue = value
-  , cookieSecure = scheme == "https"
+  { cookieDomain = BS.pack $ domain
+  , cookiePath = BS.pack $ path
+  , cookieName = BS.pack $ name
+  , cookieValue = BS.pack $ value
+  , cookieSecure = "https" `isPrefixOf` scheme
+  , cookieHttpOnly = "Only" `isSuffixOf` scheme
   , cookieExpire = guard (not $ null expire) >> readMay expire >.= fromInteger
   }
 argCookie [domain,path,name,value,scheme] = argCookie [domain,path,name,value,scheme,""]
@@ -75,35 +80,40 @@ argCookie _ = Nothing
 cookieExpires :: Cookie -> String
 cookieExpires = maybe "" ((show :: Integer -> String) . round) . cookieExpire
 
-writeCookie :: Cookie -> Maybe String
-writeCookie Cookie{ cookieExpire = Nothing } = Nothing
-writeCookie c = Just $ intercalate "\t" wc where
-  wc = 
-    [ cookieDomain c
-    , tf (headMay (cookieDomain c) == Just '.')
-    , cookiePath c
-    , tf $ cookieSecure c
-    , cookieExpires c 
-    , cookieName c
-    , cookieValue c
-    ]
+writeCookieTxt :: Cookie -> Maybe String
+writeCookieTxt Cookie{ cookieExpire = Nothing } = Nothing
+writeCookieTxt c = Just $ intercalate "\t" $
+  [ (guard (cookieHttpOnly c) >> "#HttpOnly_") ++ BS.unpack (cookieDomain c)
+  , tf $ not (BS.null (cookieDomain c)) && BS.head (cookieDomain c) == '.'
+  , BS.unpack $ cookiePath c
+  , tf $ cookieSecure c
+  , cookieExpires c 
+  , BS.unpack $ cookieName c
+  , BS.unpack $ cookieValue c
+  ] where
   tf False = "FALSE"
   tf True = "TRUE"
 
 cookieArgs :: Cookie -> [String]
-cookieArgs c = [cookieDomain c, cookiePath c, cookieName c, cookieValue c, if cookieSecure c then "https" else "http", cookieExpires c]
+cookieArgs c = 
+  [ BS.unpack $ cookieDomain c
+  , BS.unpack $ cookiePath c
+  , BS.unpack $ cookieName c
+  , BS.unpack $ cookieValue c
+  , (if cookieSecure c then "https" else "http") ++ (guard (cookieHttpOnly c) >> "Only")
+  , cookieExpires c]
 
 loadCookiesWith :: (String -> Maybe Cookie) -> FilePath -> IO [Cookie]
 loadCookiesWith c = mapMaybe c . lines .=< readFile
 
 loadElinksCookies :: FilePath -> IO Cookies
 loadElinksCookies = Set.fromList .=< loadCookiesWith parseElinksCookie
 
-loadCookies :: FilePath -> IO Cookies
-loadCookies = Set.fromDistinctAscList .=< loadCookiesWith parseCookie
+loadCookiesTxt :: FilePath -> IO Cookies
+loadCookiesTxt = Set.fromDistinctAscList .=< loadCookiesWith parseCookieTxt
 
-saveCookies :: FilePath -> Cookies -> IO ()
-saveCookies f = writeFile f . unlines . mapMaybe writeCookie . Set.toAscList
+saveCookiesTxt :: FilePath -> Cookies -> IO ()
+saveCookiesTxt f = writeFile f . unlines . mapMaybe writeCookieTxt . Set.toAscList
 
 cookiesArgs :: Cookies -> [[String]]
 cookiesArgs = map cookieArgs . Set.toList

Event.hs

@@ -6,6 +6,7 @@ module Event
 import Prelude hiding (log)
 
 import Control.Monad
+import qualified Data.ByteString.Char8 as BS
 import Data.List
 import qualified Data.Map as Map
 import Data.Maybe
@@ -73,7 +74,7 @@ allow bt dom = do
   fromMaybe (blockModeDefault b) =.< c
 
 acceptCookie :: Cookie -> UzblM Bool
-acceptCookie c = allow "cookie" (cookieDomain c)
+acceptCookie c = allow "cookie" (BS.unpack $ cookieDomain c)
 
 addCookie :: [String] -> UzblM ()
 addCookie args = maybe badArgs ac $ argCookie args where

huzblem.hs

@@ -33,20 +33,23 @@ removeFile_ :: FilePath -> IO ()
 removeFile_ f = void $ tryJust (\e -> guard (isDoesNotExistError e) >. ()) $ removeFile f
 
 data Options = Options
-  { optionSocket :: FilePath
+  { optionSocket :: Maybe String
   , optionCookies :: Maybe FilePath
   , optionDebug :: Bool
   , optionConfig :: Config
   }
 
 defaultOptions :: Options
 defaultOptions = Options
-  { optionSocket = uzblHome ".huzblem"
-  , optionCookies = Just $ uzblHome "cookies" -- home </> ".elinks/cookies"
+  { optionSocket = Nothing
+  , optionCookies = Just $ uzblHome "cookies.txt"
   , optionDebug = False
   , optionConfig = defaultConfig
   }
 
+defaultSocket :: FilePath
+defaultSocket = uzblHome ".huzblem"
+
 optionConfig' :: (Config -> Config) -> Options -> Options
 optionConfig' f o = o{ optionConfig = f (optionConfig o) }
 
@@ -59,8 +62,8 @@ setConfig c = case break ('=' ==) c of
 options :: [GetOpt.OptDescr (Options -> Options)]
 options = 
   [ GetOpt.Option "s" ["socket"] 
-      (GetOpt.ReqArg (\s o -> o{ optionSocket = if isAbsolute s then s else optionSocket o ++ '-' : s }) "PATH") 
-      ("path or suffix for event manager socket [" ++ optionSocket defaultOptions ++ "]")
+      (GetOpt.ReqArg (\s o -> o{ optionSocket = Just s }) "NAME|PATH") 
+      ("suffix or absolute path for event manager socket [" ++ defaultSocket ++ "]")
   , GetOpt.Option "" ["cookies"]
       (GetOpt.OptArg (\s o -> o{ optionCookies = s }) "FILE") 
       ("Load and use cookies from FILE [" ++ fromMaybe "NONE" (optionCookies defaultOptions) ++ "]")
@@ -89,7 +92,7 @@ main = do
   hSetEncoding stdout latin1
 
   s <- socket AF_UNIX Stream defaultProtocol
-  let sock = optionSocket opts
+  let sock = maybe defaultSocket (\p -> if isAbsolute p then p else defaultSocket ++ '-' : p) $ optionSocket opts
       sa = SockAddrUnix sock
       ifdne e = guard (isDoesNotExistError e) >. ()
 
@@ -107,8 +110,9 @@ main = do
   cookies <- case optionCookies opts of
     Nothing -> return emptyCookies
     Just f 
+      | Just f' <- stripPrefix "elinks:" f -> loadElinksCookies f'
       | ".elinks/" `isInfixOf` f -> loadElinksCookies f
-      | otherwise -> loadCookies f
+      | otherwise -> loadCookiesTxt f
 
   let uu [] = [Nothing]
       uu l = map (Just . expandURI) l
@@ -165,9 +169,7 @@ client global (s,_) = do
         bracket_ 
           (ucl $ return . Map.insert (clientKey c) c)
           (ucl $ return . Map.update (\c' -> guard (on (/=) uzblThread c c') >. c') (clientKey c))
-          (evalStateT (runReaderT (proc c) c) emptyState{
-              uzblCookies = uzblemCookies global
-            })
+          (evalStateT (runReaderT (proc c) c) emptyState)
     _ -> putStrLn $ "huzblem: bad start: " ++ l
 
 proc :: UzblClient -> UzblM ()