quarantimer 1.20200323 → 1.20200326
raw patch · 9 files changed
+349/−77 lines, 9 filesdep +sandidep +wai-extra
Dependencies added: sandi, wai-extra
Files
- CHANGELOG +27/−0
- Config.hs +5/−0
- Image.hs +17/−9
- README +3/−0
- TODO +2/−4
- quarantimer.cabal +3/−1
- quarantimer.hs +150/−57
- static/js.js +90/−3
- static/style.css +52/−3
CHANGELOG view
@@ -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 <id@joeyh.name> Thu, 26 Mar 2020 14:06:29 -0400+ quarantimer (1.20200323) unstable; urgency=medium * First release.
Config.hs view
@@ -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
Image.hs view
@@ -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
README view
@@ -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 <joeyh@joey.name> by email with any bug reports, questions, or patches.
TODO view
@@ -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.
quarantimer.cabal view
@@ -1,5 +1,5 @@ Name: quarantimer-Version: 1.20200323+Version: 1.20200326 Cabal-Version: >= 1.8 Maintainer: Joey Hess <id@joeyh.name> 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
quarantimer.hs view
@@ -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
static/js.js view
@@ -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'; } } }
static/style.css view
@@ -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 {