Remove Model.Shares

parent 2c32876e
......@@ -98,7 +98,6 @@ library
Model.Project.Signup.Internal
Model.ResetPassphrase
Model.Role
Model.Shares
Model.User
Model.User.Internal
Model.Volunteer
......
{-# LANGUAGE TupleSections #-}
module Model.Shares where
import Import
import Data.String (fromString)
import System.Random (randomIO)
import Text.Julius (rawJS)
import qualified Data.Text as T
import qualified Data.Text.Read as T
import Model.Currency
pledgeSizes :: [[Int64]]
pledgeSizes =
[ [1,2,4,8]
, [1,2,4,8,16]
, [1,2,3,5,10]
, [1,2,5,10]
]
pledgeListKey :: Text
pledgeListKey = "pledge_list"
newtype SharesPurchaseOrder = SharesPurchaseOrder Int64
pledgeField :: ProjectId -> Field Handler SharesPurchaseOrder
pledgeField _project_id = Field
{ fieldParse = parse
, fieldView = view
, fieldEnctype = UrlEncoded
}
where
parse [] _ = return $ Left $ SomeMessage MsgValueRequired
parse (x:_) _
| "-other" `T.isSuffixOf` x = do
mv <- lookupGetParam x
case mv of
Nothing -> return $ Left $ SomeMessage MsgValueRequired
Just v -> return $ parseValue v
| otherwise = return $ parseValue x
parseValue v =
let shares = Right . Just . SharesPurchaseOrder
invalidInteger i = Left $ SomeMessage $ fromString
"Number of shares must be an integer: " <> i
in case T.decimal v of
Right (a, "") -> shares a
Right (a, bs) ->
if T.all (== '0') $ T.tail bs
then shares a
else invalidInteger v
_ -> invalidInteger v
view ident name attrs v req = do
list <- handlerToWidget get_list
let value = either (const 2) (\(SharesPurchaseOrder s) -> s) v
hasValue = value `elem` list
otherValue = if hasValue then "" else show value
pledgeOptions = zip list $ map (show . millMilray) list
$(widgetFile "pledge-field")
get_list = do
mlist <- lookupSession pledgeListKey
case mlist of
Nothing -> do
r <- liftIO randomIO
let idx = mod r $ length pledgeSizes
sizes = pledgeSizes !! idx
setSession pledgeListKey $ T.pack $ show sizes
return sizes
Just t -> return $ read $ T.unpack t
pledgeForm :: ProjectId -> Form SharesPurchaseOrder
pledgeForm project_id extra = do
muser <- lift maybeAuthId
shares <- case muser of
Nothing -> return 0
Just user_id ->
fmap (sum . map unValue) $ lift $ runDB $
select $ from $ \pledge -> do
where_ $ pledge ^. PledgeProject ==. val project_id
&&. pledge ^. PledgeUser ==. val user_id
return $ pledge ^. PledgeShares
(result, pledge_view) <-
mreq (pledgeField project_id)
""
(if shares > 0 then Just (SharesPurchaseOrder shares) else Nothing)
let view = $(widgetFile "pledge-form")
return (result, view)
-- |previewPledgeForm is used for previewing a project page when editing
previewPledgeForm :: Form SharesPurchaseOrder
previewPledgeForm extra = do
let view = [whamlet|
#{extra}
<p>
<strong>
[Pledge form…]
|]
return (FormSuccess $ SharesPurchaseOrder 0, view)
......@@ -5,7 +5,6 @@ module View.Project
, projectContactForm
, inviteForm
, Preview (..)
, projectConfirmPledgeForm
, viewForm
) where
......@@ -20,7 +19,6 @@ import Data.Order
import DeprecatedBootstrap
import Handler.Utils
import Model.Project
import Model.Shares
import Model.Role
import Widgets.Markdown
......@@ -66,8 +64,3 @@ viewForm = renderBootstrap3 BootstrapBasicForm $ liftA2 (,)
(fmap (either (const defaultOrder) id . parseOrderExpression
. fromMaybe "")
(aopt' textField "sort" Nothing))
projectConfirmPledgeForm :: Maybe Int64 -> Form SharesPurchaseOrder
projectConfirmPledgeForm =
renderBootstrap3 BootstrapBasicForm . fmap SharesPurchaseOrder
. areq hiddenField ""
#{extra}
<h3>Pledge your support!
<p .pledge-explanation>
Your pledge is a matching offer inviting others to come help,
and when you pledge, existing patrons will donate more as well!
<h4>Read the details:
<ul>
<li>
The pledge mechanism
<li>
Setting your pledge level
<span .pledge-text>You pledge each month to donate:
^{fvInput pledge_view}
<span .pledge-text>for each patron to this project.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment