-- eidolon -- A simple gallery in Haskell and Yesod -- Copyright (C) 2015 Amedeo Molnár -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published -- by the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . module Helper where import Prelude import Yesod.Static import Model import Data.Maybe import Data.List as L import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import Data.Time import Data.Char import Database.Persist import System.Random import Yesod import Numeric (readHex, showHex) import Network.Mail.Mime import Text.Blaze.Html.Renderer.Utf8 import Codec.Picture getUserIdFromText :: T.Text -> UserId getUserIdFromText tempUserId = case key of Left a -> error $ T.unpack a Right k -> k where key = keyFromValues $ pInt64 : [] pInt64 = PersistInt64 $ fromIntegral (read $ T.unpack tempUserId :: Integer) extractKey :: PersistEntity record => Key record -> T.Text extractKey = extractKey' . keyToValues where extractKey' [PersistInt64 k] = T.pack $ show k extractKey' _ = "" packKey :: PersistEntity record => T.Text -> Key record packKey = keyFromValues' . readText where readText t = PersistInt64 (fromIntegral $ read $ T.unpack t) keyFromValues' v = case keyFromValues [v] of Left err -> error $ T.unpack err Right k -> k fromHex :: String -> BL.ByteString fromHex = BL.pack . hexToWords where hexToWords (c:c':text) = let hex = [c, c'] (word, _):_ = readHex hex in word : hexToWords text hexToWords _ = [] -- strict variant fromHex' :: String -> B.ByteString fromHex' = B.concat . BL.toChunks . fromHex toHex :: B.ByteString -> T.Text toHex = T.pack . concatMap mapByte . B.unpack where mapByte = pad 2 '0' . flip showHex "" pad len padding s | length s < len = pad len padding $ padding:s | otherwise = s makeRandomToken :: IO T.Text makeRandomToken = (T.pack . take 16 . randoms) `fmap` newStdGen generateSalt :: IO B.ByteString generateSalt = (B.pack . take 8 . randoms) <$> getStdGen tagField :: Monad m => Field m [T.Text] tagField = Field { fieldParse = \rawVals _ -> do case rawVals of [x] -> case L.null [x] of False -> return $ Right $ Just $ removeItem "" $ T.splitOn " " x True -> return $ Right $ Nothing _ -> return $ Left $ error "unexpected tag list" , fieldView = \idAttr nameAttr attrs eResult _ -> [whamlet||] , fieldEnctype = UrlEncoded } userField :: Monad m => [(T.Text, UserId)] -> Field m [UserId] userField users = Field { fieldParse = \rawVals _ -> do case rawVals of [x] -> case x == "" of False -> -- clean = removeItem "" $ T.splitOn " " x let ids = map (\u -> lookup u users) (removeItem "" $ T.splitOn " " x) in case Nothing `elem` ids of False -> return $ Right $ Just $ nub $ map fromJust ids True -> return $ Left $ error "Invalid username list" True -> return $ Right $ Just $ [] _ -> return $ Left $ error "unexpected username list" , fieldView = \idAttr nameAttr attrs eResult _ -> [whamlet||] , fieldEnctype = UrlEncoded } getUsersFromResult :: Eq b => [(T.Text, b)] -> [b] -> T.Text getUsersFromResult users res = T.intercalate " " $ map (\x -> fromMaybe "" $ reverseLookup x users) res sendMail :: MonadIO m => T.Text -> T.Text -> Html -> m () sendMail toEmail subject body = liftIO $ renderSendMail Mail { mailFrom = Address Nothing "noreply" -- TODO: set sender Address , mailTo = [Address Nothing toEmail] , mailCc = [] , mailBcc = [] , mailHeaders = [("Subject", subject)] , mailParts = [[Part { partType = "text/html; charset=utf-8" , partEncoding = None , partFilename = Nothing , partHeaders = [] , partContent = renderHtml body }]] } generateString :: IO T.Text generateString = (toHex . B.pack . take 16 . randoms) <$> newStdGen removeItem :: Eq a => a -> [a] -> [a] removeItem _ [] = [] removeItem x (y:ys) | x == y = removeItem x ys | otherwise = y : removeItem x ys reverseLookup :: Eq b => b -> [(a, b)] -> Maybe a reverseLookup s ((x, y):zs) | s == y = Just x | s /= y = reverseLookup s zs reverseLookup _ [] = Nothing reverseLookup _ _ = Nothing acceptedTypes :: [T.Text] acceptedTypes = -- PNG [ "image/png" -- BMP , "image/x-ms-bmp" , "image/x-bmp" , "image/bmp" -- JPG , "image/jpeg" , "image/jpg" -- GIF , "image/gif" -- Radiance , "image/vnd.radiance" -- Targa , "image/x-targa" , "image/x-tga" -- Tiff , "image/tiff" , "image/tiff-fx" -- SVG , "image/svg+xml" -- PDF , "application/pdf" ] iso8601 :: FormatTime t => t -> String iso8601 time = formatTime defaultTimeLocale (iso8601DateFormat $ Just "%H:%M:%S") time ++ zone where zone = case formatTime defaultTimeLocale "%z" time of (sig:digits@(h1:h2:m1:m2)) | sig `elem` ("+-" :: String) && all isDigit digits -> sig:h1:h2:':':m1:m2 _ -> "Z" localTimeToZonedTime :: TimeZone -> LocalTime -> ZonedTime localTimeToZonedTime tz = utcToZonedTime tz . localTimeToUTC tz rfc822 :: FormatTime t => t -> String rfc822 = formatTime defaultTimeLocale rfc822DateFormat mediumStaticImageRoute :: Medium -> Route Static mediumStaticImageRoute medium = StaticRoute (drop 2 $ T.splitOn "/" $ T.pack $ mediumPath medium) [] mediumStaticThumbRoute :: Medium -> Route Static mediumStaticThumbRoute medium = StaticRoute (drop 2 $ T.splitOn "/" $ T.pack $ mediumThumb medium) [] getThumbWidth :: MonadIO m => Maybe String -> m Int getThumbWidth path | path == Nothing = pure 230 | otherwise = liftIO $ do eorig <- readImage $ fromJust path case eorig of Right orig -> do let img = convertRGBA8 orig return $ imageWidth img Left e -> error e multiFileField :: (Monad m) => Field m [FileInfo] multiFileField = Field { fieldParse = \_ files -> return $ case files of [] -> Right Nothing _:_ -> Right $ Just files , fieldView = \id' name attrs _ isReq -> toWidget [hamlet| |] , fieldEnctype = Multipart }