eidolon/Helper.hs

111 lines
2.9 KiB
Haskell
Raw Normal View History

2014-08-13 22:52:57 +00:00
module Helper
( getUserIdFromText
2014-08-14 00:25:18 +00:00
, extractKey
-- , getUserNameById
2014-08-24 19:42:42 +00:00
, fromHex
, fromHex'
, toHex
, makeRandomToken
, generateSalt
2014-08-30 18:23:57 +00:00
, tagField
2014-09-03 23:15:27 +00:00
, sendMail
, generateString
2014-08-13 22:52:57 +00:00
)
where
import Prelude
2014-08-15 11:24:14 +00:00
import Model
import Control.Applicative
import Control.Monad.Trans.Class
import Data.Maybe
2014-08-30 21:36:23 +00:00
import Data.Either
2014-08-24 19:42:42 +00:00
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as BC
import qualified Data.Text as T
2014-08-15 11:24:14 +00:00
import Database.Persist
2014-08-13 22:52:57 +00:00
import Database.Persist.Types
2014-08-15 11:24:14 +00:00
import System.FilePath
2014-08-24 19:42:42 +00:00
import System.Random
2014-08-15 11:24:14 +00:00
import Yesod.Persist.Core
import Yesod.Core.Types
2014-08-30 18:23:57 +00:00
import Yesod
2014-08-24 19:42:42 +00:00
import Numeric (readHex, showHex)
2014-09-03 23:15:27 +00:00
import Network.Mail.Mime
import Text.Blaze.Html.Renderer.Utf8
2014-08-13 22:52:57 +00:00
2014-08-24 19:42:42 +00:00
getUserIdFromText :: T.Text -> UserId
2014-08-13 22:52:57 +00:00
getUserIdFromText tempUserId =
2014-08-24 19:42:42 +00:00
Key $ PersistInt64 $ fromIntegral $ read $ T.unpack tempUserId
2014-08-14 00:25:18 +00:00
2014-08-24 19:42:42 +00:00
extractKey :: KeyBackend backend entity -> T.Text
2014-08-14 00:25:18 +00:00
extractKey = extractKey' . unKey
where
2014-08-24 19:42:42 +00:00
extractKey' (PersistInt64 k) = T.pack $ show k
2014-08-14 00:25:18 +00:00
extractKey' _ = ""
2014-08-15 11:24:14 +00:00
--getUserNameById :: UserId -> Text
--getUserNameById userId =
2014-08-15 11:24:14 +00:00
-- let
-- user = runDB $ getJust $ userId
2014-08-15 11:24:14 +00:00
-- in
-- userName user
2014-08-24 19:42:42 +00:00
fromHex :: String -> BL.ByteString
fromHex = BL.pack . hexToWords
where hexToWords (c:c':text) =
let hex = [c, c']
2014-08-26 02:37:56 +00:00
(word, _):_ = readHex hex
2014-08-24 19:42:42 +00:00
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
2014-08-30 18:23:57 +00:00
-- tagField :: Field Handler [T.Text]
tagField = Field
{ fieldParse = \rawVals _ -> do
case rawVals of
[x] -> return $ Right $ Just $ T.splitOn " " x
_ -> return $ Left $ error "unexpected tag list"
2014-08-30 21:36:23 +00:00
, fieldView = \idAttr nameAttr val eResult isReq ->
[whamlet|<input id=#{idAttr} type="text" name=#{nameAttr} value=#{either id (T.intercalate " ") eResult}>|]
2014-08-30 18:23:57 +00:00
, fieldEnctype = UrlEncoded
}
2014-09-03 23:15:27 +00:00
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