eidolon/Helper.hs

--  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 <http://www.gnu.org/licenses/>.

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|<input id=#{idAttr} type="text" name=#{nameAttr} *{attrs} value=#{either id (T.intercalate " ") eResult}>|]
  , 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|<input id=#{idAttr} type="text" name=#{nameAttr} *{attrs} value=#{either id (getUsersFromResult users) eResult}>|]
  , 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|
            <input id=#{id'} name=#{name} *{attrs} type=file :isReq:required multiple="" enctype="multipart/form-data">
        |]
    , fieldEnctype = Multipart
    }