diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,30 @@ +quarantimer (1.20200326) unstable; urgency=medium + + * Incorportated new research from + https://www.medrxiv.org/content/10.1101/2020.03.15.20036673v1 + - Increase metal from 3 to 7 days (for stainless steel in particular) + - Add cloth, with 2 days + - Add paper, with 3 hours + - Add surgical mask, with 1 year timeout, as virus was still + detectable after 7 days and it is not known how long it would + remain infectious. It doesn't make sense to time-qurantine surgical + masks; they should be disinfected if necessary; they were added just + so people don't pick cloth for them and reuse after 2 days. + * Remove "other" choice. Existing timers for other will still last 72 hours. + * Once quarantine expires, show how long it's been since expiry in case the + user is feeling extra careful. + * Limit the allowed image formats to png, gif, jpg. In particular + don't accept video, which imagemagic would explode into one image + per frame. + * Improve styling of form. + * Poll hourly to detect when the server has been restarted, and reload + the page so the most up-to-date version is displayed. + * Use webrtc to capture photo, less clunky and allows scaling client-side + for faster upload. + * Display intersticial while uploading. + + -- Joey Hess Thu, 26 Mar 2020 14:06:29 -0400 + quarantimer (1.20200323) unstable; urgency=medium * First release. diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -11,3 +11,8 @@ numImageCores :: Int numImageCores = 1 + +-- Port that the server also listens for http traffic on. +-- This allows using the server even when it can't bind to low ports. +devPort :: Int +devPort = 7070 diff --git a/Image.hs b/Image.hs --- a/Image.hs +++ b/Image.hs @@ -22,14 +22,22 @@ _ <- atomically $ tryPutTMVar v r queueRunnerThread q +allowedImageTypes :: [String] +allowedImageTypes = ["PNG", "GIF", "JPEG"] + scaleImage :: Int -> FilePath -> FilePath -> IO Bool scaleImage maxsz src dst = do - p <- spawnProcess "convert" - [ src - , "-resize" - -- The ">" makes it only shrink large images, not scale up - -- small. - , show maxsz ++ "x" ++ show maxsz ++ ">" - , dst - ] - (== ExitSuccess) <$> waitForProcess p + (_,t,_) <- readCreateProcessWithExitCode + (proc "identify" ["-format", "%m", src]) "" + if t `elem` allowedImageTypes + then do + p <- spawnProcess "convert" + [ src + , "-resize" + -- The ">" makes it only shrink large images, + -- not scale up small. + , show maxsz ++ "x" ++ show maxsz ++ ">" + , dst + ] + (== ExitSuccess) <$> waitForProcess p + else return False diff --git a/README b/README --- a/README +++ b/README @@ -7,5 +7,8 @@ certificate, but it will listen on http, so you can use certbot to get a letsencrypt certificate, and then restart the server. +Note that https is needed for webrtc to work to take the photo. +(localhost will work without https). + Contact Joey Hess by email with any bug reports, questions, or patches. diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,7 +1,5 @@ -* Use webrtc to capture photo, less clunky and allows scaling client-side - for faster upload. -* Once quarantine expires, show how long it's been since expiry in case the - user is feeling extra careful. +* Check if the MediaDevices API is not suported and fall back to file + upload. * Expire old images after some reasonable amount of time. This can be done with just a find command. * Add systemd service file and Makefile to install it better. diff --git a/quarantimer.cabal b/quarantimer.cabal --- a/quarantimer.cabal +++ b/quarantimer.cabal @@ -1,5 +1,5 @@ Name: quarantimer -Version: 1.20200323 +Version: 1.20200326 Cabal-Version: >= 1.8 Maintainer: Joey Hess Author: Joey Hess @@ -34,6 +34,7 @@ , lucid (== 2.9.12) , aeson (>= 1.4.2 && < 1.5) , wai (== 3.2.*) + , wai-extra , warp (== 3.2.*) , warp-tls (== 3.2.*) , uuid (== 1.3.*) @@ -45,6 +46,7 @@ , directory , process , stm + , sandi Other-Modules: Config Image diff --git a/quarantimer.hs b/quarantimer.hs --- a/quarantimer.hs +++ b/quarantimer.hs @@ -15,9 +15,9 @@ import Servant.Multipart import Lucid import Lucid.Base (makeAttribute) -import Network.Wai (Application) import Network.Wai.Handler.Warp import Network.Wai.Handler.WarpTLS +import Network.Wai.Parse import Data.UUID import Data.UUID.V4 import Data.Aeson @@ -26,8 +26,11 @@ import Data.Maybe import Data.List import Data.Time.Clock +import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Codec.Binary.Base64 as B64 import Text.Read import System.FilePath import Control.Monad @@ -45,17 +48,21 @@ :> MultipartForm Tmp (MultipartData Tmp) :> Post '[HTML] UserPage :<|> "surfaces" :> Get '[JSON] [Surface] + :<|> "sessionid" :> Get '[JSON] SessionID :<|> "static" :> Raw :<|> ".well-known" :> Raw newtype UserID = UserID UUID deriving (Eq, Show) +instance FromHttpApiData UserID where + parseUrlPiece t = UserID <$> parseUrlPiece t + newtype SurfaceID = SurfaceID Int deriving (Eq, Show, ToJSON, Generic) -instance FromHttpApiData UserID where - parseUrlPiece t = UserID <$> parseUrlPiece t +newtype SessionID = SessionID UUID + deriving (Eq, Show, ToJSON, Generic) data Thing = Thing { thingSurface :: Surface @@ -70,6 +77,7 @@ , surfaceDesc :: T.Text , surfaceIcon :: UrlString , surfaceSecondsUntilSafe :: Integer + , surfaceDeprecated :: Bool } deriving (ToJSON, Generic) @@ -85,10 +93,10 @@ p_ "hello" toHtmlRaw = toHtml -data UserPage = UserPage UserID [Thing] +data UserPage = UserPage UserID SessionID [Thing] instance ToHtml UserPage where - toHtml (UserPage _ things) = html_ $ do + toHtml (UserPage _ (SessionID sid) things) = html_ $ do meta_ [ name_ "viewport" , content_ "width=device-width, initial-scale=1" @@ -100,8 +108,53 @@ , rel_ "stylesheet" , type_ "text/css" ] + script_ $ + "var sessionid = \"" <> T.pack (toString sid) <> "\";" + script_ $ + "var imagesize = " <> T.pack (show maxImageSize) <> ";" script_ [src_ "/static/js.js"] ("" :: T.Text) body_ $ do + let photograbber = div_ [class_ "camera"] $ do + video_ [id_ "video"] "Video stream not available." + canvas_ [id_ "canvas"] mempty + img_ [id_ "photo"] + + let f = form_ + [ method_ "post" + , action_ "post" + , enctype_ "multipart/form-data" + , onsubmit_ "validateform();" + ] $ do + input_ + [ type_ "hidden" + , name_ "photo" + , id_ "formphoto" + ] + input_ + [ type_ "button" + , id_ "capturebutton" + , value_ "Take photo" + ] + forM_ surfaces $ \surface -> + unless (surfaceDeprecated surface) $ do + br_ [] + let (SurfaceID s) = surfaceID surface + input_ + [ type_ "checkbox" + , class_ "surface" + , id_ (surfaceDesc surface) + , name_ (surfaceDesc surface) + , value_ (T.pack (show s)) + ] + label_ [ for_ (surfaceDesc surface)] + (toHtml ((surfaceDesc surface))) + br_ [] + input_ + [ type_ "submit" + , id_ "uploadbutton" + , value_ "Add" + ] + header_ $ do h1_ $ do a_ [href_ "/"] "Quarantimer" @@ -109,35 +162,25 @@ p_ $ do "When you have something that may " "be contaminated, take its picture, " + "select the surfaces it has, " "and this page will tell you when " "it's safe to touch it." - form_ - [ method_ "post" - , action_ "post" - , enctype_ "multipart/form-data" - , onsubmit_ "validateform();" - ] $ do - input_ - [ type_ "file" - , name_ "photo" - , camera + photograbber + + div_ + [ id_ "uploadmsg" + , style_ "display: none;" ] - forM_ surfaces $ \surface -> do - br_ [] - let (SurfaceID sid) = surfaceID surface - input_ - [ type_ "checkbox" - , class_ "surface" - , id_ (surfaceDesc surface) - , name_ (surfaceDesc surface) - , value_ (T.pack (show sid)) - ] - label_ [ for_ (surfaceDesc surface)] - (toHtml ((surfaceDesc surface))) - br_ [] - input_ [type_ "submit", value_ "Add"] + "Uploading, please wait.." + div_ + [ id_ "uploadover" + , style_ "display: none;" + ] + mempty + f + forM_ things $ \thing -> div_ [class_ "thing"] $ do img_ [ class_ "photo" @@ -154,10 +197,13 @@ footer_ $ do p_ $ do - "Covid-19 data from " + "Based on data from " a_ [href_ "https://www.nejm.org/doi/10.1056/NEJMc2004973"] "Aerosol and Surface Stability of SARS-CoV-2 as Compared with SARS-CoV-1" - " (March 17, 2020)" + " (March 17, 2020) and " + a_ [href_ "https://doi.org/10.1101/2020.03.15.20036673"] + "Stability of SARS-CoV-2 in different environmental conditions" + " (March 18, 2020). Timers will update as improved research becomes available." p_ $ do "Quarantimer " a_ [href_ "https://git.joeyh.name/index.cgi/quarantimer.git/"] @@ -189,14 +235,16 @@ hSetBuffering stderr LineBuffering createDirectoryIfMissing False staticDir q <- mkImageQueue + sid <- SessionID <$> nextRandom + let app = serveWithContext httpAPI ctx (server q sid) forM_ [1..numImageCores] $ \_ -> async $ queueRunnerThread q void $ - waitthread "https" (runTLS tlssettings (setPort 443 settings) (app q)) + waitthread "https" (runTLS tlssettings (setPort 443 settings) app) `concurrently` - waitthread "http" (runSettings (setPort 80 settings) (app q)) + waitthread "http" (runSettings (setPort 80 settings) app) `concurrently` - waitthread "http 8080" (runSettings (setPort 7070 settings) (app q)) + waitthread "http 8080" (runSettings (setPort devPort settings) app) where settings = defaultSettings tlssettings = tlsSettingsChain @@ -205,6 +253,14 @@ (le "privkey.pem") le = "/etc/letsencrypt/live" hostname + ctx = multipartOpts :. EmptyContext + multipartOpts = (defaultMultipartOptions (Proxy :: Proxy Tmp)) + -- the photo is sent base64 encoded, so bump + -- this limit + { generalOptions = setMaxRequestParmsSize 6533600 + defaultParseRequestBodyOptions + } + waitthread d a = do t <- async a res <- waitCatch t @@ -218,19 +274,17 @@ staticUserFileUrl :: UserID -> FilePath -> UrlString staticUserFileUrl (UserID u) f = staticFileUrl (toString u f) -app :: ImageQueue -> Application -app q = serve httpAPI (server q) - httpAPI :: Proxy HttpAPI httpAPI = Proxy -server :: ImageQueue -> Server HttpAPI -server q = topPage - :<|> userPage +server :: ImageQueue -> SessionID -> Server HttpAPI +server q sid = topPage + :<|> userPage sid :<|> thingList :<|> addThing q :<|> addThing' q :<|> surfaceList + :<|> sessionId sid :<|> serveDirectoryWebApp staticDir :<|> serveDirectoryWebApp (staticDir ".well-known") @@ -244,33 +298,63 @@ let redirto = B8.pack ("/" ++ show u ++ "/") throwError $ err303 { errHeaders = [("Location", redirto)] } -userPage :: UserID -> Handler UserPage -userPage u = UserPage u <$> thingList u +userPage :: SessionID -> UserID -> Handler UserPage +userPage sid u = UserPage u sid <$> thingList u +sessionId :: SessionID -> Handler SessionID +sessionId sid = do + liftIO $ logMessage "sessionid requested" + return sid + surfaceList :: Handler [Surface] -surfaceList = return surfaces +surfaceList = pure surfaces -- Per https://www.nejm.org/doi/10.1056/NEJMc2004973 surfaces :: [Surface] surfaces = + -- https://www.nejm.org/doi/10.1056/NEJMc2004973 [ Surface (SurfaceID 1) "cardboard" (staticFileUrl "cardboard.jpg") - (hours 24) + (hours 24) False + -- https://doi.org/10.1101/2020.03.15.20036673 + -- tissue and printing paper + , Surface (SurfaceID 4) "paper" + (staticFileUrl "paper.jpg") + (hours 3) False + -- https://doi.org/10.1101/2020.03.15.20036673 + , Surface (SurfaceID 5) "cloth" + (staticFileUrl "cloth.jpg") + (days 2) False , Surface (SurfaceID 2) "plastic" (staticFileUrl "plastic.jpg") - (hours 72) - , Surface (SurfaceID 3) "metal" - (staticFileUrl "metal.jpg") - (hours 72) - -- copper much less time, but don't expect people to + (hours 72) False + -- https://doi.org/10.1101/2020.03.15.20036673 + -- 7 days for stainless steel + -- + -- https://www.nejm.org/doi/10.1056/NEJMc2004973 + -- had a lower number of 72 hours for stainless. + -- + -- Last much less time on copper, but don't expect people to -- know what is copper and what looks like copper but is -- not.. + , Surface (SurfaceID 3) "metal" + (staticFileUrl "metal.jpg") + (days 7) False + -- https://doi.org/10.1101/2020.03.15.20036673 + -- found virus after 7 days in outer layer of surgical mask. + -- Unknown how long it lasts, and they should be discarded or + -- sterilized, so use 1 year as the timeout. + , Surface (SurfaceID 6) "surgical mask" + (staticFileUrl "mask.jpg") + (days 365) False , Surface (SurfaceID 0) "other" (staticFileUrl "other.jpg") - (hours 72) + (hours 72) + True -- do not offer as a selection any more ] where hours n = 60*60*n + days n = 24 * hours n addThing' :: ImageQueue -> UserID -> MultipartData Tmp -> Handler UserPage addThing' q u d = do @@ -280,7 +364,7 @@ addThing :: ImageQueue -> UserID -> MultipartData Tmp -> Handler Thing addThing q user@(UserID u) d = case parseform of Nothing -> throwError err400 - Just (s, f) -> do + Just (s, p) -> do fid <- liftIO nextRandom -- The filename contains the SurfaceID, and the UserID. -- The creation time of the file indicates when to start @@ -292,8 +376,11 @@ let destfile = staticDir newfile liftIO $ createDirectoryIfMissing False (takeDirectory destfile) + let tmp = destfile <.> "tmp" + liftIO $ B.writeFile tmp p ok <- liftIO $ queueAction q $ - scaleImage maxImageSize f destfile + scaleImage maxImageSize tmp destfile + liftIO $ removeFile tmp liftIO $ logMessage $ "image converted and saved: " ++ show ok ++ " " ++ T.unpack (surfaceDesc s) now <- liftIO getCurrentTime @@ -313,18 +400,24 @@ -- with the longest time until safe. s <- listToMaybe $ reverse $ sortOn surfaceSecondsUntilSafe $ filter (\x -> surfaceID x `elem` sids) surfaces - f <- fdPayload <$> lookupFile "photo" d - return (s, f) + -- The photo is sent base64 encoded, so decode it. + photodata <- lookupInput "photo" d + let b = T.encodeUtf8 $ T.drop 1 $ snd $ T.break (== ',') photodata + p <- case B64.decode b of + Left _ -> Nothing + Right v -> Just v + return (s, p) -- Most recently added first. thingList :: UserID -> Handler [Thing] thingList user@(UserID u) = liftIO $ do - logMessage "got a user's thing list" exists <- doesDirectoryExist userdir - if exists + l <- if exists then reverse . sortOn thingQuarantineStarted . catMaybes <$> (mapM go =<< getDirectoryContents userdir) else return [] + logMessage $ "got a user's list of " ++ show (length l) ++ " things" + return l where go f = case parsefnsurface f of Nothing -> return Nothing @@ -332,7 +425,7 @@ mtime <- getModificationTime (userdir f) now <- getCurrentTime let secsold = max 0 (floor (diffUTCTime now mtime)) - let ts = max 0 (surfaceSecondsUntilSafe s - secsold) + let ts = surfaceSecondsUntilSafe s - secsold return $ Just $ Thing { thingSurface = s , thingPhoto = staticUserFileUrl user f diff --git a/static/js.js b/static/js.js --- a/static/js.js +++ b/static/js.js @@ -1,4 +1,12 @@ var things; +var streaming=false; +var imageheight; +var video; +var canvas; +var photo; +var formphoto; +var capturebutton; +var uploadbutton; window.onload=function(){ var loaddate = Date.now(); @@ -15,8 +23,69 @@ } animate(); + checkSessionId(); + + video = document.getElementById('video'); + canvas = document.getElementById('canvas'); + photo = document.getElementById('photo'); + formphoto = document.getElementById('formphoto'); + capturebutton = document.getElementById('capturebutton'); + uploadbutton = document.getElementById('uploadbutton'); + + capturebutton.addEventListener('click', function(ev) { + togglevideo(); + ev.preventDefault(); + }, false); + uploadbutton.addEventListener('click', function(ev) { + takephoto(); + }, false); + video.addEventListener('canplay', function(ev){ + streaming = true; + imageheight = video.videoHeight / (video.videoWidth/imagesize); + video.setAttribute('width', imagesize); + canvas.setAttribute('width', imagesize); + canvas.setAttribute('height', imageheight); + photo.setAttribute('width', imagesize); + photo.setAttribute('height', imageheight); + }, false); } +function togglevideo() { + if (streaming) { + takephoto(); + } else { + photo.style.display = "none"; + video.style.display = "block"; + var constraints = { video: { facingMode: "environment" }, audio: false }; + navigator.mediaDevices.getUserMedia(constraints) + .then(function(stream) { + video.srcObject = stream; + video.play(); + }) + .catch(function(err) { + console.log("An error occurred: " + err); + }); + } +} + +function takephoto() { + if (streaming) { + var context = canvas.getContext('2d'); + context.drawImage(video, 0, 0, imagesize, imageheight); + var data = canvas.toDataURL('image/png'); + photo.setAttribute('src', data); + formphoto.value = data; + video.style.display = "none"; + photo.style.display = "block"; + + video.srcObject.getTracks().forEach(function(track) { + track.stop(); + }); + video.srcObject = null; + streaming = false; + } +} + function displayUnit(v,u) { var s; if (v == 1) { s = "" } else { s = "s" } @@ -38,13 +107,28 @@ displayUnit(m,"minute") } else { img.className = "safe"; - timer.innerHTML = "quarantine completed"; + timer.innerHTML = "quarantine completed " + + displayUnit((h*-1),"hour") + " ago" } } setTimeout(animate,10000); // keep updating every 10s } +function checkSessionId() { + var xhttp = new XMLHttpRequest(); + xhttp.onreadystatechange = function() { + if (this.readyState == 4 && this.status == 200) { + if (JSON.parse(this.responseText) != sessionid) { + location.reload(true); + } + } + }; + xhttp.open("GET", "/sessionid", true); + xhttp.send(); + setTimeout(checkSessionId, 3600000); // check every hour +} + function validateform() { var surfaces=document.getElementsByClassName("surface"); var sok=false; @@ -53,8 +137,7 @@ sok=true; } } - photo=document.getElementsByName("photo")[0]; - if (photo.value.length == 0) { + if (formphoto.value.length == 0) { alert("Please take a photo of the thing you want to quarantine."); event.preventDefault(); } @@ -62,6 +145,10 @@ if (! sok) { alert("Please indicate what the surface of the item is made of."); event.preventDefault(); + } + else { + document.getElementById('uploadmsg').style.display = 'block'; + document.getElementById('uploadover').style.display = 'block'; } } } diff --git a/static/style.css b/static/style.css --- a/static/style.css +++ b/static/style.css @@ -1,13 +1,62 @@ -footer { - padding: 24px; - margin: 0 auto; +header, footer { + margin: 5 auto; background-color: #EFEFEF; width: 100%; box-sizing: border-box; + border-radius: 24px; } +header { + padding: 5px; +} + +footer { + padding: 24px; +} + h1 { font-size: calc(16px + (26 - 16) * ((100vw - 300px) / (1600 - 300))); +} + +input#capturebutton, input#uploadbutton { + height: 3em; +} + +#uploadmsg { + color: black; + background: #fff; + padding: 10px; + position: fixed; + top: 50%; + left: 25%; + z-index: 100; + margin-right: -25%; + margin-bottom: -25%; +} + +#uploadover { + background: black; + z-index: 99; + width: 100%; + height: 100%; + position: fixed; + top: 0; + left: 0; + filter: alpha(opacity=80); + opacity: 0.8; +} + +video { + max-width: 50%; + display: none; +} + +img#photo { + display: none +} + +canvas { + display: none; } img {